Loop through a range to create a tree of nested data - excel

Question

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.

Answer 1

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.
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

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"):
It will return Worksheets("Output"):
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.

Answer 3

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