如何创建 Excel 层次结构

Question

我正在尝试创建一个 Excel 层次结构（与这个问题非常相似）

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

我想将其作为枢轴 table 中的可扩展层次结构或通过 VBA（以更容易的为准），如下所示：

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

这是我想要实现的示例。

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

谢谢，斯蒂芬.

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

它会输出

如何创建 Excel 层次结构

How to create an Excel Hierarchy

excel

vba

pivot-table