Question

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

例如，零件 12345 是通过组合 abc 和 def 来构建的。

我有一个顶级部分的列表，还有一个第二列的列表，其中两列分别在左侧显示了顶层，在右侧显示了子部分。

例如：

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

我对每个循环使用a来遍历第一个表中的每个部分，并将其与第二个表进行比较，然后将每个子部分返回到右侧。但是，我正在努力超越一个层次。

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

-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循环，它将重新扫描子零件的列表，每次找到该零件时将变量更改为新的零件号，并且一旦零件中不存在该零件就停止运行清单。

尽管如此，我仍无法提出一种可行的方法。

Answer 1

我尝试使用字典和递归函数来呈现结果。您可以对其进行一些调整以仅显示顶部。当前，它显示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

Answer 2

我建议遍历您的Top Level Part和Sub Part列表，并使用WorksheetFunction.Match Method向后追溯每个条目的路径。

从此列表Worksheets("List")发送的邮件：

它将返回Worksheets("Output")：

只需按A B C和D列进行排序即可获取树视图字符。

Option Explicit

Public Sub FindPathway()
    Dim wsList As Worksheet
    Set wsList = ThisWorkbook.Worksheets("List")

    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Worksheets("Output")

    Dim LastRow As Long
    LastRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row

    Dim OutputRow As Long, oCol As Long
    OutputRow = 2

    Dim PathCol As Collection
    Dim FoundRow As Long

    Dim iRow As Long, cRow As Long
    For iRow = 2 To LastRow
        cRow = iRow
        Set PathCol = New Collection
        PathCol.Add wsList.Cells(cRow, "B").Value

        Do 'loop until a root item is found
            FoundRow = 0
            On Error Resume Next
                FoundRow = WorksheetFunction.Match(wsList.Cells(cRow, "A"), wsList.Columns("B"), 0)
            On Error GoTo 0

            If FoundRow = 0 Then
                'is a root
                PathCol.Add wsList.Cells(cRow, "A").Value
                For oCol = 0 To PathCol.Count - 1 'output all remembered items
                    wsOutput.Cells(OutputRow, oCol + 1).Value = PathCol.Item(PathCol.Count - oCol)
                Next oCol
                OutputRow = OutputRow + 1
            Else
                'is a child
                PathCol.Add wsList.Cells(cRow, "A").Value 'remember item
                cRow = FoundRow 'go for the next child item
            End If
            DoEvents 'prevent unresponsive Excel
        Loop Until FoundRow = 0
    Next iRow
End Sub

请注意，此方法非常基础，而且不是最快的方法，因为它无法识别已跟踪的路径，而是始终对每个项目进行完整的跟踪。

Answer 3

把我的帽子扔进戒指。可以自定义tgr子项，以查找数据和输出结果的位置。它还将跟踪实际是什么，并且仅对那些项目及其子部分执行递归搜索。递归搜索功能为FindAllSubParts

Sub tgr()

    Const sDataSheet As String = "Sheet2"
    Const sResultSheet As String = "Sheet1"
    Const sTopPartsCol As String = "A"
    Const sSubPartsCol As String = "B"

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rTopParts As Range
    Dim rSubParts As Range
    Dim TopPartCell As Range
    Dim rTest As Range
    Dim hTopParts As Object

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets(sDataSheet)
    Set wsDest = wb.Sheets(sResultSheet)
    Set rTopParts = wsData.Range(sTopPartsCol & "2", wsData.Cells(wsData.Rows.Count, sTopPartsCol).End(xlUp))
    Set rSubParts = Intersect(rTopParts.EntireRow, wsData.Columns(sSubPartsCol))
    Set hTopParts = CreateObject("Scripting.Dictionary")

    For Each TopPartCell In rTopParts.Cells
        Set rTest = Nothing
        Set rTest = rSubParts.Find(TopPartCell.Text, rSubParts.Cells(rSubParts.Cells.Count), xlValues, xlWhole, , xlNext, False)
        If rTest Is Nothing And Not hTopParts.Exists(TopPartCell.Text) Then
            hTopParts.Add TopPartCell.Text, TopPartCell.Text
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Value = TopPartCell.Text
            FindAllSubParts TopPartCell.Text, 1, rTopParts, rSubParts, wsDest, sTopPartsCol
        End If
    Next TopPartCell

End Sub

Sub FindAllSubParts(ByVal arg_sTopPart As String, _
                    ByVal arg_lSubIndex As Long, _
                    ByVal arg_rTopParts As Range, _
                    ByVal arg_rSubParts As Range, _
                    ByVal arg_wsDest As Worksheet, _
                    ByVal arg_sTopPartsCol As String)

    Dim rFound As Range
    Dim sFirst As String
    Dim sSubPart As String

    Set rFound = arg_rTopParts.Find(arg_sTopPart, arg_rTopParts.Cells(arg_rTopParts.Cells.Count), xlValues, xlWhole, , xlNext, False)
    If Not rFound Is Nothing Then
        sFirst = rFound.Address
        Do
            sSubPart = arg_rSubParts.Parent.Cells(rFound.Row, arg_rSubParts.Column).Text
            arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_sTopPartsCol).End(xlUp).Offset(1).Value = String(arg_lSubIndex, "-") & sSubPart
            FindAllSubParts sSubPart, arg_lSubIndex + 1, arg_rTopParts, arg_rSubParts, arg_wsDest, arg_sTopPartsCol
            Set rFound = arg_rTopParts.Find(arg_sTopPart, rFound, xlValues, xlWhole, , xlNext, False)
        Loop While rFound.Address <> sFirst
    End If

End Sub

VBA遍历范围以创建嵌套数据树

3 个答案: