VBA Проход по диапазону для создания дерева вложенных данных

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

Бросаю шляпу на ринг.Подставка 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

Answer 3

Я предлагаю пройтись по вашему списку Top Level Part и Sub Part и использовать метод WorksheetFunction.Match для обратного отслеживания пути каждой записи.

Исходящий из этого списка Worksheets("List"):

Вернется Worksheets("Output"):

Который должен быть отсортирован только по столбцам ABC и 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

Обратите внимание, что этот метод очень простой и не самый быстрый, поскольку он не распознает уже прослеженные пути.вместо этого он всегда делает полный след для каждого элемента.