如何创建 Excel 层次结构

Question

我正在尝试创建 Excel 层次结构（与此问题非常相似） Creating an excel hierarchy

但我的 Excel 文件的结构完全不同。 请通过对比查看我的文件布局：

我希望将其作为数据透视表中的可扩展层次结构或通过 VBA（更简单的方法），如下所示：

虽然上图显示了层，但我想要的输出将使用层值。这就是上面提到的结构意味着它不像链接问题中的步骤那么容易。

这是我想要实现的示例。

任何帮助或指导将不胜感激。

谢谢， 斯特凡。

Answer 1

脚本只需要这些列：

Option Explicit

Public Sub Example()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Source")
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' read data into array
    Dim PartNumber() As Variant
    PartNumber = ws.Range("D2", "D" & LastRow).Value

    Dim PartDescription() As Variant
    PartDescription = ws.Range("E2", "E" & LastRow).Value

    Dim PartLevel() As Variant
    PartLevel = ws.Range("F2", "F" & LastRow).Value

    Dim PartParent() As Variant
    PartParent = ws.Range("G2", "G" & LastRow).Value
    
    ' creat a tree
    Dim RootTree As Object
    Set RootTree = CreateObject("Scripting.Dictionary")
    
    ' fill tree with data
    Dim iRow As Long
    For iRow = LBound(PartNumber, 1) To UBound(PartNumber, 1)
        If PartLevel(iRow, 1) = 0 Then
            ' create root
            ' ------------
            RootTree.Add PartNumber(iRow, 1), CreateObject("Scripting.Dictionary")
        Else
            ' create all children
            ' --------------------
            Dim BacktraceLevel As Long
            BacktraceLevel = PartLevel(iRow, 1)
            ReDim Backtrace(1 To BacktraceLevel)
            
            Backtrace(BacktraceLevel) = PartParent(iRow, 1)
            BacktraceLevel = BacktraceLevel - 1
            
            ' backtrace from current child to root
            Do While BacktraceLevel > 0
                DoEvents
                Dim FoundAt As Double
                FoundAt = Application.WorksheetFunction.Match(Backtrace(BacktraceLevel + 1), PartNumber, 0)
                If PartLevel(FoundAt, 1) <> 0 Then
                    Backtrace(BacktraceLevel) = PartParent(FoundAt, 1)
                End If
                BacktraceLevel = BacktraceLevel - 1
            Loop
            
            ' climb tree until child can be added
            Dim Parent As Object
            Set Parent = RootTree
            Dim b As Long
            For b = 1 To UBound(Backtrace)
                Set Parent = Parent(Backtrace(b))
            Next b
            
            ' add current child
            Parent.Add PartNumber(iRow, 1), CreateObject("Scripting.Dictionary")
        End If
    Next iRow
    
    ' output tree
    OutputTree RootTree, Worksheets("output").Range("A1"), PartNumber, PartDescription
End Sub

Private Sub OutputTree(ByVal Tree As Object, ByVal StartOutput As Range, ByVal PartNumber As Variant, ByVal PartDescription As Variant, Optional ByVal Level As Long = 0)
    Static iRow As Long
    
    Dim Key As Variant
    For Each Key In Tree.Keys
        StartOutput.Offset(RowOffset:=iRow, ColumnOffset:=Level).Value = PartDescription(Application.WorksheetFunction.Match(Key, PartNumber, 0), 1)
        iRow = iRow + 1
        If VarType(Tree(Key)) = 9 Then
            OutputTree Tree(Key), StartOutput, PartNumber, PartDescription, Level + 1
        End If
    Next
End Sub

它会输出