I am trying to create an Excel hierarchy (very similar to this question)

I would like to have this as an expandable hierarchy in a pivot table or through VBA (whatever is easier) like the below:

Whilst the image above shows Tier, my desired output would use the Level value. This is where the structure mentioned above means it isn't as easy as following the steps from the linked question.

Here is an example of what I would like to achieve.

Any help or guidance would be much appreciated.

Thanks, Stefan.

CodePudding user response：

The script will only need those columns:

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

And it will output