4

I need to create a list of part numbers, which shows all other sub parts that are used to create that first part.

So for example part 12345 is built by combining abc and def.

I have a list of the top level parts, and a second list with two columns showing the top level on the left, and the sub part on the right.

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   |

I have used a for each loop to look through each part in the first table and compare it to the second, returning each sub part to the right. However I am struggling to go deeper than one level.

What I want to be able to do is once the sub part is found to loop back through the list looking for that part number and returning it's sub part. And continuing until the part is no longer found. Effectively giving me a tree.

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

The loop I am using initially is this:

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

I have considered using a while loop inside of this which would re scan the list for the sub part, changing the variable to the new part number each time one is found, and stop running once the part doesn't exist in the list.

I can't come up with a working way to implement this though.

4
  • 1
    How many levels of nesting do you have in your actual data? This could get complicated.
    – SJR
    Commented Oct 10, 2018 at 11:44
  • 1
    At most it will be 4
    – Edward144
    Commented Oct 10, 2018 at 12:00
  • I think it would be best to first determine the actual level of each subpart. This can get complicated as one needs to know what either the deepest, or the top most part is, which is hard to interpret from such a list of data. Would be best to have this at some fixed place when possible.
    – Luuklag
    Commented Oct 10, 2018 at 12:28
  • Well, you can use some sort of back tracing mechanism for each item. Not the most efficient way to do it but it does work without knowing any fix points nor does it need information about the level depth. The deeper the levels get the more inefficient this method is. See my answer.
    – Pᴇʜ
    Commented Oct 10, 2018 at 13:58

3 Answers 3

4

i tried using dictionaries and a recursive function to present the results. you can tweak it a bit to only show the top parts. Currently it shows every item that is in column A. Column C is the output.

The idea is that i am looping through the column A and i create a dictionary for each part and has entries in the dictionary the sub parts.

When i present the results if an entry in the dictionary is also an entry in my top level dictionary i present it again.

enter image description here

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
1

I suggest looping through your list of Top Level Part and Sub Part and use the WorksheetFunction.Match Method to backwards trace the path of each entry.

Outgoing from this list Worksheets("List"):

enter image description here

It will return Worksheets("Output"):

enter image description here

Which only needs to be sorted by columns A B C and D to get the tree view character.

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

Note that this method is very basic and not the fastest, because it doesn't recognize already traced paths, instead it always does a full trace for every item.

1

Throwing my hat in the ring. The tgr sub can be customized for where to look for the data and where to output the results. It will also keep track of what is actually top level and only perform the recursive search for those items and their sub parts. The recursive search function is 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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.