Automatic Grouping Excel VBA

Question

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?

Answer 1

The code you have arrived at seems a little convoluted to me. Change to your needs and try this:

Sub groupTest()
    Dim sRng As Range, eRng As Range ' Start range, end range
    Dim rng As Range
    Dim currRng As Range

    Set currRng = Range("B1")

    Do While currRng.Value <> ""
        Debug.Print currRng.Address
        If sRng Is Nothing Then
            ' If start-range is empty, set start-range to current range
            Set sRng = currRng
        Else
        ' Start-range not empty
            ' If current range and start range match, we've reached the same index & need to terminate
            If currRng.Value <> sRng.Value Then
                Set eRng = currRng
            End If

            If currRng.Value = sRng.Value Or currRng.Offset(1).Value = "" Then
                Set rng = Range(sRng.Offset(1), eRng)
                rng.EntireRow.Group
                Set sRng = currRng
                Set eRng = Nothing
            End If
        End If

        Set currRng = currRng.Offset(1)
    Loop
End Sub

Note that there is no error-handling here, the code is a little verbose for readability and bonus - no select .

Edit:

As requested, the subgrouping. This actually had me stuck for a bit - I coded myself into a corner and only barely got out on my own!

A few notes:

I have tested this to some extent (with 4 sublevels and multiple parents) and it works nicely. I tried to write the code so that you can have as many sublevels or as many parents as you want. But it has not been extensively tested, so I couldn't guarantee anything.

However, for some scenarios, Excel won't properly display the + -signs, I am guessing that is due to lack of space in these particular scenarios. If you encounter this, you can contract and expand the different levels using the numbered buttons at the top of the column the + -signs are located in. This will expand/contract all groups of that particular sub-level, however, so it is not optimal. But it is what it is.

Assuming a setup like this (this is after the grouping - you can see the missing + -signs here, for example for group 1.3 and 3.1 -- but they are grouped !):

Sub subGroupTest()
    Dim sRng As Range, eRng As Range
    Dim groupMap() As Variant
    Dim subGrp As Integer, i As Integer, j As Integer
    Dim startRow As Range, lastRow As Range
    Dim startGrp As Range, lastGrp As Range

    ReDim groupMap(1 To 2, 1 To 1)
    subGrp = 0
    i = 0
    Set startRow = Range("A1")

    ' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
    Do While (startRow.Offset(i).Value <> "")
        groupMap(1, i + 1) = startRow.Offset(i).Address
        groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
        If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
        ReDim Preserve groupMap(1 To 2, 1 To (i + 2))

        Set lastRow = Range(groupMap(1, i + 1))
        i = i + 1
    Loop

    ' Destroy already existing groups, otherwise we get errors
    On Error Resume Next
    For k = 1 To 10
        Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
    Next k
    On Error GoTo 0

    ' Create the groups
    ' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
    Do While (subGrp > 0)
        For j = LBound(groupMap, 2) To UBound(groupMap, 2)
            If groupMap(2, j) >= CStr(subGrp) Then
            ' If current value in the map matches the current group index

                ' Update group range references
                If startGrp Is Nothing Then
                    Set startGrp = Range(groupMap(1, j))
                End If
                Set lastGrp = Range(groupMap(1, j))
            Else
                ' If/when we reach this loop, it means we've reached the end of a subgroup

                ' Create the group we found in the previous loops
                If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group

                ' Then, reset the group ranges so they're ready for the next group we encounter
                If Not startGrp Is Nothing Then Set startGrp = Nothing
                If Not lastGrp Is Nothing Then Set lastGrp = Nothing
            End If
        Next j

        ' Decrement the index
        subGrp = subGrp - 1
    Loop
End Sub

Answer 2

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.