VBA how to calculate depth of items in excel simliar to a BOM system

Question

I'm working on a macro that takes an excel spreadsheet which contains a parent column and a child column. The macro's goal is to determine each product's depth in a BOM tree. Moreover, the spreadsheet may contain many BOM trees.

I've thought of having the root of the tree be given an initial value of 0 and then doing a check of it's children and take their parents value and adding 1. Nevertheless, I am unsure about how to go about doing it effectively because, according to my current idea, I must have certain relation-based checks and repeat them throughout the entire BOM tree.

I've managed to identify which product is a child of another product so far, but I'm having trouble figuring out how to calculate the depth.

This is what I currently have done.

Sub findParents(startRange As String, searchValue As String, endRow As String, realtionArray() As String)
    Do While True
        With Worksheets("Test").range(startRange & endRow)
        Set c = .Find(searchValue, LookIn:=xlValues)
            If c Is Nothing Then ' string not found
                Exit Do
            Else ' string found
                startRange = "B" & CStr(c.Row + 1)
                Debug.Print c & "'s parent is " & range("A" & CStr(c.Row)).value
            End If
        End With
    Loop
End Sub
Sub BOM()

    Dim c As range
    Dim searchValue As String
    Dim startRange As String
    Dim endRow As String
    Dim searchValues() As Variant
    Dim iNum As Integer
    Dim varData As Variant
    Dim relationArray() As String
    
    
    endRow = ":B" & CStr(range("B" & Rows.Count).End(xlUp).Row + 1)
    searchValues = range("D2:D" & CStr(range("D" & Rows.Count).End(xlUp).Row))

    For iNum = 1 To UBound(searchValues)
        startRange = "B2"
        searchValue = searchValues(iNum, 1)
        findParents startRange, searchValue, endRow, relationArray
    Next iNum
    
    
 End Sub

This is the test data I'm working with.

Answer 1

Add on the sheet an ActiveX Microsoft Treeview Control (version 6.0) named "TreeView1" with "/" as PathSeparator (to be sure provide the separator even if it's already it) and run this macro:

Sub SubTree()
    
    Dim obj As Object
    Dim rng As Range
    Dim cell As Range
    Dim str As String
    Dim mynode As Node
    Dim Index As Double
    Dim MaxIndex As Double
    Dim MinIndex As Double
    Dim lvl As Double
    
    Set rng = Range("A2:E11")
    
    On Error Resume Next
    Set obj = ActiveSheet.Shapes("TreeView1")
    On Error GoTo 0
    
    If obj Is Nothing Then
        MsgBox "Create in the sheet a ActiveX Microsoft Treeview Control (version 6.0) named ""TreeView1"" with ""/"" as PathSeparator and re-run the macro", vbCritical + vbOKOnly
        Exit Sub
    End If
    
    obj.OLEFormat.Object.Object.Nodes.Clear
    
    For Each cell In rng.Columns(1).Cells
        If Excel.WorksheetFunction.CountIf(rng.Columns(2), cell.Value2) = 0 Then
            On Error Resume Next
            obj.OLEFormat.Object.Object.Nodes.Add Key:=cell.Value2, Text:=cell.Value2
            On Error GoTo 0
        End If
    Next
    
    MinIndex = 1
    
    
CP_Child_Nodes_Start:
    MaxIndex = obj.OLEFormat.Object.Object.Nodes.Count
    For Index = MinIndex To MaxIndex
        Set mynode = obj.OLEFormat.Object.Object.Nodes(Index)
        For Each cell In rng.Columns(1).Cells
            If cell.Value2 = Split(mynode.Key, "\")(UBound(Split(mynode.Key, "\"))) Then
                Debug.Print mynode.FullPath
                If Len(Replace(mynode.FullPath, "\" & cell.Offset(0, 1).Value2, "")) = Len(mynode.FullPath) Then
                    obj.OLEFormat.Object.Object.Nodes.Add mynode, tvwChild, mynode.FullPath & "\" & cell.Offset(0, 1).Value2, cell.Offset(0, 1).Value2
                Else
                    If Left(mynode.Text, 6) <> "#LOOP:" Then
                        obj.OLEFormat.Object.Object.Nodes.Add mynode, tvwChild, mynode.FullPath & "\" & cell.Offset(0, 1).Value2, "#LOOP:" & cell.Offset(0, 1).Value2
                    End If
                End If
            End If
        Next
    Next
    
    If MinIndex > MaxIndex Then GoTo CP_Child_Nodes_End
    MinIndex = MaxIndex + 1
    
    GoTo CP_Child_Nodes_Start
    
CP_Child_Nodes_End:
    
    For Each cell In rng.Columns(1).Cells
        str = cell.Value2 & "\" & cell.Offset(0, 1).Value2
        lvl = 0
        For Each mynode In obj.OLEFormat.Object.Object.Nodes
            
            If Not mynode.Parent Is Nothing Then
                
                If Len(Replace(mynode.Key, str, "")) <> Len(mynode.Key) Then
                    
                    For Index = Len(mynode.Key) To 1 Step -1
                        
                        If Left(Right(mynode.Key, Index), Len(str)) = str Then
                            Exit For
                        End If
                        
                    Next
                    
                    lvl = Excel.WorksheetFunction.Max(lvl, UBound(Split(Left(mynode.Key, Len(mynode.Key) - Index), "\")))
                    Debug.Print
                    Debug.Print mynode.Key
                    Debug.Print mynode.Text
                    Debug.Print mynode.FullPath
                    If mynode.Parent Is Nothing Then
                        Debug.Print "."
                    Else
                        Debug.Print mynode.Root
                    End If
                    Debug.Print str, lvl
                End If
            End If
        Next
        
        cell.Offset(0, 4).Value2 = lvl
        lvl = 0
    Next
End Sub