Automatic Grouping Excel VBA

user_5826539 0
Viewed 8216

This Question has been answered, however I need help with one point. I am using the code provided in the answer, however I can not get the subgrouping, for the entirety of the document. Is such thing possible?

Section    Index
   1          1
+  1.1        2
++ 1.1.1      3
+++1.1.1.1    4
+++1.1.1.2    4
+++1.1.1.3    4
++ 1.1.2      3
++ 1.1.3      3
+  1.2        2
+  1.3        2
   2          1

NOTE: Plusses shows groups.

I have such table as above, where I have indexed the sections with sublevels. I am trying to group those section using excel group feature, however, I have over 3000 rows of data, so I am trying to automate the process. I have modified a Excel VBA macro I found here and got this code below.

Sub AutoGroupBOM()
'Define Variables
Dim StartCell As Range 'This defines the highest level of assembly, usually 1, and must be the top leftmost cell of concern for outlining, its our starting point for grouping'
Dim StartRow As Integer 'This defines the starting row to beging grouping, based on the row we define from StartCell'
Dim LevelCol As Integer 'This is the column that defines the assembly level we're basing our grouping on'
Dim LastRow As Integer 'This is the last row in the sheet that contains information we're grouping'
Dim CurrentLevel As Integer 'iterative counter'
Dim groupBegin, groupEnd As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer

Application.ScreenUpdating = False 'Turns off screen updating while running.

'Prompts user to select the starting row. It MUST be the highest level of assembly and also the top left cell of the range you want to group/outline"
Set StartCell = Application.InputBox("Select levels' column top cell", Type:=8)
StartRow = StartCell.Row
LevelCol = StartCell.Column
LastRow = ActiveSheet.UsedRange.End(xlDown).Row 'empty rows above aren't included in UsedRange.rows.count => UsedRange.End

'Remove any pre-existing outlining on worksheet, or you're gonna have 99 problems and an outline ain't 1
Cells.ClearOutline

'Walk down the bom lines and group items until you reach the end of populated cells in the assembly level column
groupBegin = StartRow + 1 'For the first group
For i = StartRow To LastRow
    CurrentLevel = Cells(i, LevelCol)
    groupBegin = i + 1
    'Goes down until the entire subrange is selected according to the index
    For n = i + 1 To LastRow
        If Cells(i, LevelCol).Value = Cells(n, LevelCol).Value Then
            If n - i = 1 Then
            Exit For
            Else
                groupEnd = n - 1
                Rows(groupBegin & ":" & groupEnd).Select
            'If is here to prevent grouping level that have only one row
            End If
            Exit For
        Else
        End If
    Next n
Next i

'For last group
Rows(groupBegin & ":" & LastRow).Select
Selection.Rows.Group

ActiveSheet.Outline.ShowLevels RowLevels:=1 'Minimize all the groups
ActiveSheet.Outline.SummaryRow = xlAbove 'Put "+" next to first line of each group instead of the bottom
Application.ScreenUpdating = True 'Turns on screen updating when done.

End Sub

Basically what I am trying to do in the above code is to select the top index and run down the cells until that index is the same value again. Basically for the example chart, I would like to select rows(2:4) and group them. This is not achieved by the code. Also, code skips grouping if the adjacent rows are with the same index.

Is this a viable method or should I re-think my loops and how?

vba excel
2 Answers

The subGroupTest() function above can be replaced by 6 lines of code:

Sub subGroupTest()
    Dim cRng As range
    Set cRng = range("A1")
    Do While cRng.Value <> ""
        cRng.EntireRow.OutlineLevel = UBound(Split(cRng.Value, ".")) + 1
        Set cRng = cRng.Offset(1)
    Loop
End Sub

Consecutive rows on the same OutlineLevel are automatically grouped together, so no need to jump through all the hoops in order to solve for the depths manually. OutlineLevel = 1 means the row is not grouped too.

As a bonus, there is no need to delete the outline levels beforehand.

user_68225280
Related