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

0 votes

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.

enter image description here

Mar 24, 2023 in Others by narikkadan
• 63,600 points
636 views

1 answer to this question.

0 votes

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
answered Mar 24, 2023 by Kithuzzz
• 38,000 points

Related Questions In Others

0 votes
1 answer

Creating a function in excel VBA to calculate the average point in a circular set of numbers

I used the following code to determine ...READ MORE

answered Oct 28, 2022 in Others by narikkadan
• 63,600 points
1,156 views
0 votes
1 answer

How to automatically get a specified range of data from Excel to XML in VBA

Range method works, always identify the sheet ...READ MORE

answered Mar 18, 2023 in Others by narikkadan
• 63,600 points
854 views
0 votes
1 answer

How to programmatically get the values of a spilled Excel range in VBA?

By using the Text property, I was ...READ MORE

answered Mar 23, 2023 in Others by narikkadan
• 63,600 points
1,273 views
0 votes
1 answer

Excel-VBA - How to identify Target range (more than 1 cell) is deleted in a Worksheet_Change function?

You misunderstand the purpose of the function ...READ MORE

answered Sep 23, 2022 in Others by narikkadan
• 63,600 points
3,755 views
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,740 points
1,249 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
3,694 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9, 2022 in Others by gaurav
• 23,260 points
957 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,690 points
1,084 views
0 votes
1 answer

Excel VBA- How to loop through specific sheets in a workbook and format the same ranges in each sheet

Range(...) instructs VBA to always use the ...READ MORE

answered Mar 21, 2023 in Others by Kithuzzz
• 38,000 points
1,789 views
0 votes
1 answer

Is there a function in excel to automatically calculate age using date of birth?

Try  =INT((YEARFRAC(TODAY(),B3,1)))  Where cell B3 contains a date like ...READ MORE

answered Mar 28, 2023 in Others by Kithuzzz
• 38,000 points
625 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP