循环遍历一个范围以创建嵌套数据树

我需要创建一个零件号列表，其中显示用于创建第一零件的所有其他子零件。

例如部分12345是通过组合构建的abc and def.

我有一个顶级部分的列表，以及第二个列表，其中有两列，左侧显示顶级，右侧显示子部分。

e.g:

| Top Level Part |                    | Top Level Part | Sub Part |
| 123456         |                    | 123456         | abc      |
| 234567         |                    | 123456         | def      |
                                      | 234567         | ghi      |
                                      | 234567         | jkl      |
                                      | abc            | yyy      |
                                      | abc            | zzz      |
                                      | yyy            | 000000   |

我使用了 for every 循环来查看第一个表中的每个部分并将其与第二个表进行比较，将每个子部分返回到右侧。然而，我正在努力超越一个层次。

我想要做的是，一旦找到子部件，就循环遍历列表，查找该部件号并返回它的子部件。并继续，直到不再找到该部件。有效地给了我一棵树。

-123456
--abc
---yyy
----000000
---zzz
--def
-234567
--ghi
--jkl

我最初使用的循环是这样的：

Dim topList as range, top as range
Dim lookupList as range, lookup as range
Dim i as integer

Set topList = .sheets("Sheet1").range("A2:A100")
set lookupList = .sheets("Sheet2").Range("A2:A1000")

i = 1

For Each top in topList
    For Each lookup in lookupList
        If (top = lookup) then
            top.offset(0, i).value = lookup.offset(0, 1))

            i = i + 1
        End If
    Next lookup
Next top

我考虑过在其中使用 while 循环，它将重新扫描列表中的子部件，每次找到一个部件时将变量更改为新的部件号，并在列表中不存在该部件时停止运行。

但我无法想出一种可行的方法来实现这一点。

我尝试使用字典和递归函数来呈现结果。您可以对其进行一些调整以仅显示顶部部分。目前它显示 A 列中的每个项目。C 列是输出。

我的想法是，我循环遍历 A 列，并为每个部分创建一个字典，并在字典中包含子部分的条目。

当我呈现结果时，如果字典中的条目也是我的顶级字典中的条目，我会再次呈现它。

Public Sub sFindParts()

  Dim topPartDict As New Dictionary, subPartDict As Dictionary, d As Dictionary
  Dim topPartList As Range, part As Range
  Dim outputLocation As Range
  Dim i As Integer, indLvl As Integer
  Dim k As Variant, p As Variant

  Set outputLocation = Sheet2.Range("C1")
  Set topPartList = Sheet2.Range("A2:A8")

  For Each part In topPartList
    If Not topPartDict.Exists(part.Value) Then
      Set d = New Dictionary
      d.Add Key:=part.Offset(0, 1).Value, item:=part.Offset(0, 1).Value
      topPartDict.Add Key:=part.Value, item:=d
      Set topPartDict(part.Value) = d
    Else
      Set d = topPartDict(part.Value)
      d.Add Key:=part.Offset(0, 1).Value, item:=part.Offset(0, 1).Value
      Set topPartDict(part.Value) = d
    End If
  Next part

  indLvl = fPresentParts(outputLocation, topPartDict, topPartDict, 0)

End Sub


Private Function fPresentParts(ByRef location As Range, ByRef tpd As Dictionary, ByRef d As Dictionary, indLvl As Integer) As Integer
  Dim k As Variant, v As Variant
  Dim subPartsDict As Dictionary

  For Each k In d.Keys()
    If TypeOf d(k) Is Dictionary Then
      Set v = d(k)
      location.IndentLevel = indLvl
      location.Value = k
      Set location = location.Offset(1, 0)
      indLvl = indLvl + 1
      Set subPartsDict = v
      indLvl = fPresentParts(location, tpd, subPartsDict, indLvl)
    Else
      If tpd.Exists(d(k)) And TypeOf tpd(d(k)) Is Dictionary Then
        location.IndentLevel = indLvl
        location.Value = d(k)
        Set location = location.Offset(1, 0)
        indLvl = indLvl + 1
        indLvl = fPresentParts(location, tpd, tpd(d(k)), indLvl)
      Else
        location.IndentLevel = indLvl
        location.Value = k
        Set location = location.Offset(1, 0)
      End If
    End If

  Next k
  indLvl = indLvl - 1
  fPresentParts = indLvl
End Function