VBA级联分组代码示例

最近跟VBA扯上了关系，甚为痛苦，不过也小有成就，这不，分享个级联分组的代码，但是由于office的Excel只支持深度为7的分组，所以无法支持无限级联，但是代码的逻辑仍然是按照无限级联的思想的。

我的Sheet主要是通过D列的数字来展示父子关系，下一行比上一行大的表示为上一行的子集。比如第四列即D列的数字为（按行数）：1 2 2 3 2。那么1以后的这些都是1这一行记录的子集，3则是最他的前一个2的子集，最后的2与3前面的2为同级关系。

好像废话很多，我不知道我是否表达得清楚，因为折腾了一周整个人够呛的，贴代码吧，不懂的再留言咯。

'以行为单位分组
Sub GroupByRows(sheet As Worksheet, startRow As Long, endRow As Long, groupLevel As Integer)
    If groupLevel > 7 Then
        Exit Sub
    End If
    With sheet
    If .Rows.count <= startRow Or endRow <= startRow Then
    Exit Sub
    End If
    
    Dim prevLevel As Integer
    Dim currLevel As Integer
    Dim levelText As String
    levelText = .Cells(startRow, 4).text
    If levelText <> "" Then
        prevLevel = CInt(levelText)
    End If
        
    Dim firstRow, lastRow As Integer
    Dim startGroup As Boolean
    Dim i, levelIndex As Integer
    For i = startRow To endRow
        If .Cells(i, 1).text = "" Then
            Exit For
        End If
        
        levelText = .Cells(i, 4).text
        If levelText <> "" Then
            currLevel = CInt(levelText)
            'If currLevel = prevLevel Then
            If currLevel > prevLevel Then
            '上一等级小，开始新组
                If startGroup = False Then
                    firstRow = i
                    levelIndex = currLevel - prevLevel
                    startGroup = True
                End If
            ElseIf currLevel <= prevLevel Then
            '上一等级大，结束分组
                lastRow = i - 1
                prevLevel = currLevel
                If startGroup And firstRow <= lastRow Then
                    
                    'On Error Resume Next  '去掉则报错，留着则有时不能完成所有数据分组
                    
                    sheet.Rows(CStr(firstRow) & ":" & CStr(lastRow)).Group
                    GroupByRows sheet, firstRow + 0, lastRow + 0, groupLevel + 1
                End If
                startGroup = False
            End If
        End If
    Next i
    Debug.Print i
    If startGroup Then
        lastRow = endRow
        If firstRow <= lastRow Then
            'On Error Resume Next
            
            sheet.Rows(CStr(firstRow) & ":" & CStr(lastRow)).Group
            GroupByRows sheet, firstRow + 0, lastRow + 0, groupLevel + 1
        End If
    End If
    End With
End Sub

调用代码

'为有层级的元数据分组示例
Sub aaa()
    unprotectAll (OptionManager.GetName("__PWD__"))
    
    Sheet2.Rows.ClearOutline
    GroupByRows Sheet2, 5, Sheet2.UsedRange.Rows.count, 1
    
    'GroupByRows Sheet2, 1781, 1785, 1
    'Sheet2.Rows("3792:3794").Group
    
    ProtectAll (OptionManager.GetName("__PWD__"))
End Sub