如何在VBA中展平父子关系列表并生成最深层级路径？

问题场景 #

现有Parent/Child父子关系表格，需将每一行子节点路径展平为尽可能深的层级结构（优先取最长路径，如Root->Offer->Pizza...），原表格不可修改或排序，最终结果用于Power Pivot Table。当前VBA代码无法正确处理同时关联Root和Offer的Pizza、Sandwich节点，导致层级缺失。

核心解决思路 #

• 构建双向字典存储节点的父/子关系，实现多父节点场景下的快速路径回溯
• 递归遍历节点的所有可能父链，筛选并保留最长路径
• 严格遵循原表格行顺序生成结果，满足不可修改排序的要求

优化后的VBA代码 #

Option Explicit

Sub FlattenLongestHierarchy()
    Dim wsSource As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim parentDict As Object, childDict As Object
    Dim node As String, currentPath As Variant, longestPath As Variant
    
    ' 初始化工作表
    Set wsSource = ThisWorkbook.Worksheets("Source") ' 替换为你的源表名
    On Error Resume Next
    Set wsOutput = ThisWorkbook.Worksheets("Flattened")
    If Err.Number <> 0 Then
        Set wsOutput = ThisWorkbook.Worksheets.Add
        wsOutput.Name = "Flattened"
    End If
    On Error GoTo 0
    wsOutput.Cells.Clear
    
    ' 构建父/子关系字典（支持多父节点）
    Set parentDict = CreateObject("Scripting.Dictionary")
    Set childDict = CreateObject("Scripting.Dictionary")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow ' 假设第一行是表头
        Dim parentNode As String, childNode As String
        parentNode = Trim(wsSource.Cells(i, "A").Value)
        childNode = Trim(wsSource.Cells(i, "B").Value)
        
        ' 子节点关联所有父节点
        If Not parentDict.Exists(childNode) Then
            Set parentDict(childNode) = CreateObject("Scripting.Dictionary")
        End If
        parentDict(childNode)(parentNode) = True
        
        ' 父节点关联所有子节点（可选，用于扩展功能）
        If Not childDict.Exists(parentNode) Then
            Set childDict(parentNode) = CreateObject("Scripting.Dictionary")
        End If
        childDict(parentNode)(childNode) = True
    Next i
    
    ' 写入结果表头
    wsOutput.Cells(1, 1).Value = "原行号"
    wsOutput.Cells(1, 2).Value = "节点"
    wsOutput.Cells(1, 3).Value = "层级1"
    wsOutput.Cells(1, 4).Value = "层级2"
    wsOutput.Cells(1, 5).Value = "层级3"
    ' 可根据实际需求扩展更多层级列
    
    ' 逐行处理源表节点，保留原顺序
    For i = 2 To lastRow
        node = Trim(wsSource.Cells(i, "B").Value)
        longestPath = GetLongestPath(node, parentDict)
        
        ' 写入基础信息
        wsOutput.Cells(i, 1).Value = i
        wsOutput.Cells(i, 2).Value = node
        
        ' 展平最长路径到层级列
        For j = 0 To UBound(longestPath)
            wsOutput.Cells(i, j + 3).Value = longestPath(j)
        Next j
    Next i
    
    ' 自动调整列宽
    wsOutput.UsedRange.Columns.AutoFit
    MsgBox "层级展平完成！", vbInformation
End Sub

' 递归获取节点的最长父路径
Function GetLongestPath(node As String, parentDict As Object) As Variant
    Dim paths As Collection, path As Variant
    Dim parentNode As Variant, tempPath As Variant
    
    Set paths = New Collection
    
    ' 无父节点时直接返回自身
    If Not parentDict.Exists(node) Then
        GetLongestPath = Array(node)
        Exit Function
    End If
    
    ' 遍历所有父节点，递归生成路径
    For Each parentNode In parentDict(node).Keys
        tempPath = GetLongestPath(parentNode, parentDict)
        ' 将当前节点追加到父路径末尾
        ReDim Preserve tempPath(UBound(tempPath) + 1)
        tempPath(UBound(tempPath)) = node
        paths.Add tempPath
    Next parentNode
    
    ' 筛选最长路径
    Dim maxLength As Long, longestIdx As Integer
    maxLength = 0
    longestIdx = 1
    For i = 1 To paths.Count
        If UBound(paths(i)) > maxLength Then
            maxLength = UBound(paths(i))
            longestIdx = i
        End If
    Next i
    
    GetLongestPath = paths(longestIdx)
End Function

代码关键说明 #

• 多父节点支持：通过嵌套字典存储每个子节点的所有父节点，解决Pizza同时关联Root和Offer的场景
• 最长路径优先：递归遍历所有可能路径后对比长度，确保返回最深层级的路径
• 原顺序保留：严格按照源表行号循环处理，完全符合原表格不可修改排序的要求
• 扩展性：可根据实际层级数量直接扩展表头的层级列，无需修改核心逻辑

内容的提问来源于stack exchange，提问作者Kochise