Using VBA to indent parent child columns

Question

I have the table below and need help indenting parent child relationships. The root node starts at 0 and can traverse 1000+ levels deep as can the child relationships.

How do i achieve this in VBA?

CPackName      CPackID      PPackID      PName      ParentID      PDATA 
Artifacts      1            1            AC         0             297
Template       1            1            AC         0             281
WA             1            1            AC         0             361
Alisha         361          361          WA         1             611 
Damian         361          361          WA         1             480
ABC            297          297          Artifacts  1             
DEF            297          297          Artifacts  1

I would like to show this in columns as below.

Answer 1

The following Excel-VBA module works for me.

Option Explicit

Type Tree_Node          ' note: and IDX of zero means that it does not exist.
    Idx As Long         'The array index of the original source record
    ParentIdx As Long   'The array index of the parent of this node
    Depth As Long       'The number of parent nodes above this node
    OutRow As Long      'The row offset this node should appear at
    Flink As Long       'next sibling of this node
    ChildCount As Long  'number of children found so far
    HeadIdx As Long     'First child node of this parent-node
    TailIdx As Long     'Last child node of this parent node
End Type
Private nod() As Tree_Node

Private maxDepth As Long

' Formats Record/Pack data into indented records.
'
'Parameters:
'   InputRange      - The source range that contains the record/pack data.
'                    (should NOT include the column headers)
'   FirstOutputCell - The top-left cell that the output data will be written to.
'                    All cells below or to the right of this may be overwritten.
'
Sub OutputIndentedRecords(InputRange As Range, FirstOutputCell As Range)
    ' Get all of the input data into a variant array
    Dim src As Variant
    src = InputRange
    Dim srcRows As Long
    srcRows = UBound(src, 1)
    ' source range column offsets
    Const CPackName = 1
    Const PPackID = 3
    Const PDATA = 6

    Dim PDataIdxs As New Collection 'collection to index the PDATA values
    ReDim nod(srcRows)  'array to hold the Tree Nodes representing each record

    '   make the zero entry the ultimate root, with no parent
    nod(0).ParentIdx = -1
    PDataIdxs.Add 0, "1"

    '   For each record in the source range, make a Tree_Node to represent it
    '(NOTE: This algorithm assumes that the parent always appears before its children
    '       in the source range.)
    Dim i As Long, j As Long
    For i = 1 To srcRows
        'is there a record here?
        If src(i, CPackName) <> "" Then
            ' Yes, so fill in the tree node
            With nod(i)

                .Idx = i
                ' Get the parent index
                .ParentIdx = PDataIdxs(CStr(src(i, PPackID)))
                ' add this node to the Parents child list
                With nod(.ParentIdx)
                    If .TailIdx <> 0 Then       'if theres already a child
                        nod(.TailIdx).Flink = i 'point it to us
                    Else                        'otherwise
                        .HeadIdx = i            'we are the head of the child list
                    End If
                    .TailIdx = i                'we are the new tail
                    .ChildCount = .ChildCount + 1
                End With

                ' Is it a potential Parent?
                If src(i, PDATA) <> "" Then
                    'yes, so flag it and index its PDATA value
                    PDataIdxs.Add i, CStr(src(i, PDATA))
                End If

            End With
        End If
    Next i

    ' Traverse the Tree structure, filling in Depth and Output row number
    Dim curRow As Long
    curRow = 1
    maxDepth = 0

    TraverseTreeDepthFirst 0, 1, curRow

    ' Make an output array and fill it in
    Dim out() As Variant
    ReDim out(curRow - 2, maxDepth - 2)
    For i = 1 To srcRows
        With nod(i)
            out(.OutRow - 2, .Depth - 2) = src(.Idx, CPackName)
        End With
    Next i

    'Make an output range to hold the array
    Dim wsOut As Worksheet, rngOut As Range
    Set wsOut = FirstOutputCell.Worksheet
    Set rngOut = wsOut.Range(FirstOutputCell, _
                            wsOut.Cells(FirstOutputCell.Row + curRow - 2, _
                                        FirstOutputCell.Column + maxDepth - 2))
    ' write out the output array
    rngOut = out
End Sub

' Depth-first tree traversal, filling in the node depth and row number
Sub TraverseTreeDepthFirst(ByVal cur As Long, ByVal curDepth As Long, ByRef curRow As Long)
    With nod(cur)

        ' set values of the current node
        .Depth = curDepth
        .OutRow = curRow
        curRow = curRow + 1
        If curDepth > maxDepth Then maxDepth = curDepth

        ' Traverse any children first
        If .HeadIdx > 0 Then
            TraverseTreeDepthFirst .HeadIdx, curDepth + 1, curRow
        End If

        ' Move to next sibling
        If .Flink > 0 Then
            TraverseTreeDepthFirst .Flink, curDepth, curRow
        End If
    End With

End Sub

Just call OutputIndentedRecords passing in the range of the source data and the first cell of the output range.

Let me know if you have any questions.

---

Here's how to setup a button to call this subroutine:

First, add the following VBA code to your subject worksheet's code module:

Sub CallOutputIndent()

    Dim src As Range
    Set src = Selection

    OutputIndentedRecords src, Worksheets("OutputWs").Cells(2, 2)

End Sub

Change the Worksheet name above from "OutputWs" to whatever you output worksheet is named. also change the (2,2) to whatever the first output cell on that worksheet should be.

Next, go to your source worksheet and from the "Insert" menu, add a button/rectangular shape. Right-click it and pick "Assign Macro..", and then assign the CallOutputIdent macro to it.

To use it, just select the input range and click the button. that should be it.