рекурсивный разбор деревьев с помощью vba

Question

Учитывая следующую электронную таблицу данных: https://ethercalc.org/q7n9zwbzym5y

У меня есть следующий код, который проанализирует это и выведет дерево из отношений родитель-потомок в листе.Обратите внимание, что тот факт, что каждый столбец встречается дважды, объясняется тем, что первый экземпляр столбца предназначен для данных другого типа, меня интересуют только заполненные столбцы.Это желаемый результат из приведенного выше листа:

Код:

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

Однако при создании этого дерева оно застревает в бесконечном циклеИндии, где, признав «Наличные» в качестве конечного элемента Индии, вместо того, чтобы выйти из этого поддерева, он создаст другую Индию и продолжит свою деятельность до переполнения.Есть ли логическая ошибка в моем коде?Часы отладки не сработали для меня, и любой вклад был бы оценен, где у меня есть недостатки в моей логике.

Answer 1

Я предполагаю, что «Main» и «Cash» всегда будут там.Если нет, то нам придется немного подправить код.Я прокомментировал код, чтобы у вас не было проблем с его пониманием.Но если вы это сделаете, просто спросите.Я быстро написал этот код, поэтому я уверен, что его можно оптимизировать:)

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

Это то, что я получил, запустив его на предоставленных вами данных.