recursive tree parsing with vba - vba

Question

Given the following spreadsheet of data: https://ethercalc.org/q7n9zwbzym5y
I have the following code that will parse this and will derive a tree from the parent-child relationships in the sheet. Note that fact that every column occurs twice is because the first instance of the columns is for another type of data, I am only concerned with the populated columns. This is the desired output from the sheet above:
Code:
Sub performanceSheet(someParams)
' Write to "Performance" sheet
Dim w1 As Worksheet, w2 As Worksheet, wsSearch As Worksheet, wsData As Worksheet
Dim num_rows
Dim parent As Range, parentName As String
Dim parentRange As Range, childrenRange As Range
Dim childCount As Long
Dim p As Variant
Dim f1 As Range, f2 As Range
currRow = 8
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set w1 = wbk.Sheets("PositionsDB")
Set w2 = wbk.Sheets("Performance")
num_rows = w1.Cells(Rows.Count, 1).End(xlUp).row
'If there's no parentName column, we can't continue.
If w1.Rows(1).Find("portfolioName") Is Nothing Then Exit Sub
'find first instance
Set f1 = w1.Rows(1).Find("portfolioName", lookat:=xlWhole)
If Not f1 Is Nothing Then
'find second instance
Set f2 = f1.Offset(0, 1).Resize(1, w1.Columns.Count - f1.Column).Find("portfolioName", lookat:=xlWhole)
If Not f2 Is Nothing Then
'set range based on f2
Set parentRange = w1.Range(f2.Offset(1, 0), _
w1.Cells(Rows.Count, f2.Column).End(xlUp))
End If
End If
'If there's no Root level, how do we know where to start?
If parentRange.Find("Main") Is Nothing Then Exit Sub
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
' Recursive method to traverse our dictionary, beginning at Root element.
Call PerformanceProcessItem("", "Main", dict, w2, 9)
wbk.Sheets("Performance").Columns("A:F").AutoFit
End Sub
Private Sub PerformanceProcessItem(parentName As String, name As String, dict As Object, ws As Worksheet, row_num As Long, Optional indent As Long = 0)
Dim output As String, v
Dim w2 As Worksheet
'Debug.Print WorksheetFunction.Rept(" ", indent) & name
'Debug.Print parentName & name
'write to sheet
ws.Cells(row_num, 3).Value = name
row_num = row_num + 1
If Not dict.Exists(name) Then
'we're at a terminal element, a child with no children.
Exit Sub
Else
For Each v In dict(name)
' ## RECURSION ##
Call PerformanceProcessItem(name, CStr(v), dict, ws, row_num, indent + 2)
Next
End If
End Sub
However, when creating this tree, it gets stuck on an infinite loop of India's, where after recognizing "Cash" as the terminal element of India, rather than exiting that subtree it will create another India and continue until overflow. Is there a logic error in my code? Hours of debugging hasn't worked for me and any input would be appreciated on where I have a flaw in my logic.

Answer 1

I am assuming that "Main" and "Cash" will always be there. If not then we will have to tweak the code little bit. I have commented the code so you may not have a problem understanding it. But if you do, simply ask. I quickly wrote this code so I am sure it can be optimized :)
Option Explicit
Dim sB As String
Dim tmpAr As Variant
Sub Sample()
Dim col As New Collection
Dim s As String
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim itm As Variant, vTemp As Variant
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Get Last Row of Col AA
lRow = .Range("AA" & .Rows.Count).End(xlUp).Row
'~~> Store Range AA:AC in an array
tmpAr = .Range("AA2:AC" & lRow).Value
End With
'~~> Create a unique collection of portfolioName
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) = "Main" Then
On Error Resume Next
col.Add tmpAr(i, 3), CStr(tmpAr(i, 3))
On Error GoTo 0
End If
Next i
'~~> Sort the collection
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i) > col(j) Then
vTemp = col(j)
col.Remove j
col.Add vTemp, vTemp, i
End If
Next j
Next i
s = "Main"
For Each itm In col
sB = vbTab & itm
s = s & vbNewLine & sB
sB = ""
GetParentChild itm, 2
If Trim(sB) <> "" Then _
s = s & vbNewLine & sB
Next itm
s = s & vbNewLine & vbTab & "Cash"
Debug.Print s
End Sub
Private Sub GetParentChild(strg As Variant, n As Integer)
Dim sTabs As String
Dim j As Long, k As Long
For k = 1 To n
sTabs = sTabs & vbTab
Next k
For j = LBound(tmpAr) To UBound(tmpAr)
If Trim(tmpAr(j, 1)) = Trim(strg) And Trim(tmpAr(j, 1)) <> "Cash" Then
sB = sB & sTabs & tmpAr(j, 3) & vbNewLine
GetParentChild tmpAr(j, 3), n + 1
End If
Next j
End Sub
This is what I got when I ran it on the data that you provided.