vba - building a dictionary of parent child key value pairs

Question

Given the following columns of data:

portfolioID portfolioName   entityID    entityName
-188    India   643365  someLeaf1
-188    India   642925  someLeaf2
-188    India   643008  someLeaf3
-188    India   66280   Cash
-187    Main    -186    Golf
-187    Main    -181    Charlie
-187    Main    66280   Cash
-187    Main    66281   Alpha
-187    Main    66283   Bravo
-186    Golf    -185    Hotel
-186    Golf    -183    Juliet
-186    Golf    66280   Cash
-185    Hotel   -188    India
-185    Hotel   397660  Xray
-185    Hotel   66280   Cash
-183    Juliet  -182    Kilo
-183    Juliet  66280   Cash
-183    Juliet  66281   Lima
-182    Kilo    596371  someLeaf4
-182    Kilo    66280   Cash
-182    Kilo    602616  someLeaf5
-182    Kilo    602617  someLeaf6
-181    Charlie -180    Delta
-181    Charlie -179    Echo
-181    Charlie 66280   Cash
-180    Delta   641311  someLeaf7
-180    Delta   641312  someLeaf8
-180    Delta   641313  someLeaf9
-180    Delta   641314  someLeaf10
-180    Delta   66280   Cash
-179    Echo    66280   Cash
-179    Echo    66281   Foxtrot

You can derive a tree from the relationships above, where portfolioName's are parents and entityName's are children:

I want to iterate over this and build a scripting dictionary of parents with childRanges. This is my current code:

For Each parent In parentRange
    If Not dict.Exists(parent.Value) Then
        childCount = Application.WorksheetFunction.CountIf(parentRange, parent.Value)
        Set childrenRange = parent.Offset(, 2).Resize(childCount, 1)
        dict.Add parent.Value, Application.Transpose(Application.Transpose(childrenRange.Value))
    End If
Next

However, this does not work when the data is not sorted by parents. How can I change my childrenRange to the proper list of children most efficiently?

Also, is it possible to always have "Cash" be the final element of the array of children?

Attempt:

for Each parent In parentRange
        If Not dict.Exists(parent.Value) Then
            childCount = Application.WorksheetFunction.CountIf(parentRange, parent.Value)
            'Set childrenRange = parent.Offset(, 2).Resize(childCount, 1)
            Dim childrenArr() As String
            ReDim childrenArr(childCount)
            Dim c As Integer
            c = 0
            For i = 1 To num_rows
                If Cells(i, f2.Column).Value = parent Then
                    childrenArr(c) = Cells(i, f2.Column).Offset(2, 0)
                    c = c + 1
                End If
            Next i
            dict.Add parent.Value, childrenArr
        End If
    Next

Answer 1

Something like this:

Sub Tester()
    Dim parentRange As Range, p As Range, c
    Dim m, childrenArr() As String, tmp
    Dim dict, childCount As Long, k
    Set dict = CreateObject("scripting.dictionary")

    Set parentRange = Range("B2:B33")

    For Each p In parentRange
        'create an empty array if a new key
        If Not dict.Exists(p.Value) Then
            childCount = Application.WorksheetFunction.CountIf(parentRange, p.Value)
            ReDim childrenArr(0 To childCount - 1)
            dict.Add p.Value, childrenArr
        End If

        tmp = dict(p.Value) '<<get the array
        c = p.Offset(0, 2).Value
        If c = "Cash" Then
            tmp(UBound(tmp)) = c
        Else
            'find first empty slot (will be 1-based)
            m = Application.Match("", tmp, 0)
            tmp(m - 1) = c 'minus one because array is 0-based
        End If
        dict(p.Value) = tmp '<<return the array
    Next

    For Each k In dict.keys
        Debug.Print k, Join(dict(k), ", ")
    Next k

End Sub

Note: if you want to work with an array contained in a dictionary you first need to pull it out of the dictionary.