如何用VBA计算Excel中BOM层级结构里物料的深度

我正在开发一个Excel宏，处理包含父项列和子项列的工作表，目标是计算BOM树中每个产品的深度。工作表里可能有多棵BOM树，我想把树的根节点初始值设为0，子节点深度为父节点值加1，但不知道怎么高效实现——需要基于关系检查并遍历整个BOM树，还没找到合适的方案。目前已经能识别产品间的父子关系，但卡在深度计算环节。

现有代码 #

Sub findParents(startRange As String, searchValue As String, endRow As String, realtionArray() As String)
    Do While True
        With Worksheets("Test").range(startRange & endRow)
        Set c = .Find(searchValue, LookIn:=xlValues)
            If c Is Nothing Then ' string not found
                Exit Do
            Else ' string found
                startRange = "B" & CStr(c.Row + 1)
                Debug.Print c & "'s parent is " & range("A" & CStr(c.Row)).value
            End If
        End With
    Loop
End Sub
Sub BOM()

    Dim c As range
    Dim searchValue As String
    Dim startRange As String
    Dim endRow As String
    Dim searchValues() As Variant
    Dim iNum As Integer
    Dim varData As Variant
    Dim relationArray() As String
    
    
    endRow = ":B" & CStr(range("B" & Rows.Count).End(xlUp).Row + 1)
    searchValues = range("D2:D" & CStr(range("D" & Rows.Count).End(xlUp).Row))

    For iNum = 1 To UBound(searchValues)
        startRange = "B2"
        searchValue = searchValues(iNum, 1)
        findParents startRange, searchValue, endRow, relationArray
    Next iNum
    
    
 End Sub

测试数据 #

工作表结构及数据如下：

• A列（父项）：空、P1、P1、P2、P3、P3
• B列（子项）：P1、C1、C2、P3、C3、C4
• D列（待计算深度的产品）：P1、C1、C2、P2、P3、C3、C4

解决方案：高效计算BOM深度 #

可以通过字典存储父子映射+递归缓存计算的方式实现，既避免重复查找，又能高效处理多棵树：

完整代码 #

Sub CalculateBOMDepth()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Test")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    ' 字典：子项 -> 父项集合
    Dim childToParents As Object
    Set childToParents = CreateObject("Scripting.Dictionary")
    
    ' 字典：产品 -> 深度（-1表示未计算）
    Dim itemDepth As Object
    Set itemDepth = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    ' 第一步：构建父子映射，初始化所有产品深度
    For i = 2 To lastRow
        Dim parentItem As String, childItem As String
        parentItem = Trim(ws.Cells(i, "A").Value)
        childItem = Trim(ws.Cells(i, "B").Value)
        
        If childItem <> "" Then
            If Not childToParents.Exists(childItem) Then
                childToParents(childItem) = New Collection
            End If
            childToParents(childItem).Add parentItem
        End If
        
        ' 初始化深度标记
        If Not itemDepth.Exists(childItem) Then itemDepth(childItem) = -1
        If parentItem <> "" And Not itemDepth.Exists(parentItem) Then itemDepth(parentItem) = -1
    Next i
    
    ' 第二步：标记根节点（无父项的产品）深度为0
    Dim key As Variant
    For Each key In itemDepth.Keys
        If Not childToParents.Exists(key) Then
            itemDepth(key) = 0
        End If
    Next key
    
    ' 第三步：递归计算所有产品深度
    For Each key In itemDepth.Keys
        If itemDepth(key) = -1 Then
            itemDepth(key) = GetItemDepth(key, childToParents, itemDepth)
        End If
    Next key
    
    ' 第四步：将结果写入E列（D列右侧）
    Dim targetRange As Range
    Set targetRange = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row)
    Dim cell As Range
    For Each cell In targetRange
        Dim targetItem As String
        targetItem = Trim(cell.Value)
        If itemDepth.Exists(targetItem) Then
            cell.Offset(0, 1).Value = itemDepth(targetItem)
        Else
            cell.Offset(0, 1).Value = "未匹配"
        End If
    Next cell
    
    MsgBox "BOM深度计算完成！"
End Sub

' 递归获取产品深度，自动缓存结果避免重复计算
Function GetItemDepth(item As String, childToParents As Object, itemDepth As Object) As Integer
    ' 已计算过直接返回
    If itemDepth(item) <> -1 Then
        GetItemDepth = itemDepth(item)
        Exit Function
    End If
    
    Dim minDepth As Integer
    minDepth = 999 ' 初始化极大值
    
    Dim parent As Variant
    For Each parent In childToParents(item)
        ' 递归计算父项深度
        Dim parentDepth As Integer
        parentDepth = GetItemDepth(parent, childToParents, itemDepth)
        ' 子项深度=父项深度+1，取最小深度（适配多父项场景）
        If parentDepth + 1 < minDepth Then
            minDepth = parentDepth + 1
        End If
    Next parent
    
    ' 缓存当前产品深度
    itemDepth(item) = minDepth
    GetItemDepth = minDepth
End Function

代码说明 #

1. 字典映射：用Scripting.Dictionary存储父子关系，比多次调用Find方法效率提升数倍，避免重复遍历工作表
2. 缓存机制：递归计算时会直接读取已缓存的深度值，不会重复计算同一个产品的层级
3. 多父项处理：如果一个子项有多个父项，自动取最小的深度值（符合BOM树中产品的最浅层级逻辑）
4. 结果输出：将计算结果写入D列右侧的E列，直接对应待计算的产品列表

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