将 Excel 表格分组为最多 7 个级别

Question

我有一些大型 Excel 表格，我必须将它们分组才能进一步使用它们。表格的内容来自一个软件，其中的内容被分成树状，最多 7 个级别。

我想通过 VBA 在 Excel 中重建这个结构。

在表格中，A 列中每行的级别如下所示：

A 列结构的级别：

最终它的结构应该像软件中一样，这样：

源码软件结构：

对于其中一张桌子，我是手工完成的。在那里你可以看到我需要的结果：

我观看了 VBA 编程的初学者课程，询问了 Chat GPT，但似乎我需要很长时间才能找到解决方案。

这是我的代码中当前编写的内容：

Sub GRUPPIEREN()
Dim mainWB  As Workbook
Dim xlFileName As String

Set mainWB = ThisWorkbook


' Schritt 2: Iterate durch Zeilen und apply groups
With mainWB.Sheets("TEST")

Dim LastRow As Long, i As Long
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

' Stukturebenen als Variablen
Dim Ebene1 As Long
Dim Ebene2 As Long
Dim Ebene3 As Long
Dim Ebene4 As Long
Dim Ebene5 As Long


' find firsts
Dim start As Long
Dim Ebene As Long
Dim Offset As Long
Offset = 0
    
For i = 2 To LastRow
    Ebene = .Range("A" & i).Value
    If Ebene = 1 Then
        Ebene1 = i
        End If
    If Ebene = 2 Then
        Ebene2 = i
        End If
    If Ebene = 3 Then
       Ebene3 = i
        End If
    If Ebene = 4 Then
       Ebene4 = i
        End If
    If Ebene = 5 Then
       Ebene5 = i
       start = i + 1
        Exit For
    End If
Next i


For i = start To LastRow
    ' check format
    Ebene = .Range("A" & i).Value
        ' Ebene 1
        If Ebene = 1 Then
            If ((i - Ebene1) > 1) Then
                ' Neue Gruppe 1
                .Rows((Ebene1) & ":" & (i - 1)).Group
                ' leere row fuer verschachtelte Gliederung
                'OLD:.Rows(i & ":" & i).EntireRow.Insert
            End If
            
            Ebene1 = i + 1
            Offset = 0
        End If
        ' Ebene 2
        If Ebene = 2 Then
            If ((i - Ebene2) > 1) Then
                ' Neue Gruppe 2
                .Rows((Ebene2 + 1) & ":" & (i - 1 - Offset)).Group
            End If
            Offset = 0
            Ebene2 = i
        End If
        ' Ebene 3
        If Ebene = 3 Then
            If ((i - Ebene3) > 1) Then
                ' Neue Gruppe 3
                .Rows((Ebene3 + 1) & ":" & (i - 1 - Offset)).Group
            End If
            Offset = 0
            Ebene3 = i
        End If
        ' Ebene 4
        If Ebene = 4 Then
            If ((i - Ebene4) > 1) Then
                ' Neue Gruppe 4
                .Rows((Ebene4 + 1) & ":" & (i - 1 - Offset)).Group
            End If
            Offset = 0
            Ebene4 = i
        End If
        ' Ebene 5
        If Ebene = 5 Then
            If ((.Range("A" & i).Value - Ebene5) > 1) Then
                ' Neue Gruppe 5
                .Rows((Ebene5 + 1) & ":" & (i - 1 - Offset)).Group
            End If
            Offset = 0
            Ebene5 = i
        End If
Next i

' Schritt 3: Schliesse uebrige Gruppen ab
' Ebene 1
If (((LastRow + 1) - Ebene1) > 1) Then
    ' Neue Gruppe 1
    .Rows((Ebene1) & ":" & (LastRow)).Group
    ' leere row fuer verschachtelte Gliederung
    'OLD:.Rows((LastRow + 1) & ":" & (LastRow + 1)).EntireRow.Insert
End If

' Ebene 2
If (((LastRow + 1) - Ebene2) > 1) Then
    ' Neue Gruppe 2
    .Rows((Ebene2 + 1) & ":" & (LastRow)).Group
End If
' Ebene 3
If (((LastRow + 1) - Ebene3) > 1) Then
    ' Neue Gruppe 3
    .Rows((Ebene3 + 1) & ":" & (LastRow)).Group
End If
' Ebene 4
If (((LastRow + 1) - Ebene4) > 1) Then
    ' Neue Gruppe 4
    .Rows((Ebene4 + 1) & ":" & (LastRow)).Group
End If
' Ebene 5
If (((LastRow + 1) - Ebene5) > 1) Then
    ' Neue Gruppe 5
    .Rows((Ebene5 + 1) & ":" & (LastRow)).Group
End If
End With 

End Sub

它分组到第 5 层，但第 1 层的第一个组的行太高：

我认为第 5 级分组很好，但所有其他级别还没有找到正确的结局：

有人可以帮我吗？我会继续尝试，但我将非常感谢您的提示和解决方案:)

Answer 1

请尝试一下。

Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, iVal As Long, iEnd As Long
    Dim LastRow As Long
    ' Get the last row#
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    With Range("A1:A" & LastRow)
        ' Clear outline
        .ClearOutline
        .Parent.Outline.SummaryRow = xlSummaryAbove
        ' Load data into an array
        arrData = .Value
    End With
    ' Loop through data
    For i = LBound(arrData) + 1 To LastRow - 1
        If arrData(i, 1) < arrData(i + 1, 1) Then
            iVal = arrData(i, 1)
            iEnd = 0
            ' Locate the end of each group
            For j = i + 2 To LastRow
                If arrData(j, 1) <= iVal Then
                    iEnd = j - 1
                    Exit For
                End If
            Next
            If iEnd = 0 Then iEnd = LastRow
            If iEnd >= i + 1 Then
                ' Group rows
                Range(Cells(i + 1, 1), Cells(iEnd, 1)).Rows.Group
            End If
        End If
    Next i
End Sub

微软文档：

范围.分组方法（Excel）

Range.ClearOutline 方法（Excel）

Outline.SummaryRow 属性 (Excel)