Multi-level Bill Of Materials explosion

[Andy Howcroft]

Hi,

I have a single level Bill Of Materials (BOM) report that shows all parent assemblies with their subsequent child parts. I need to create a complete record of multi-level BOMs for all our products with the BOM level shown for each assembly/part.

Please note:

• The child part can also be an assembly and therefore appears in the ‘Parent’ column.
• The child parts/assemblies can be used in multiple assemblies.
• The BOM level can be 20+.
• We have 2,500 products and 10,000+ parts/assemblies and so the resulting report will be rather large.

Current report showing two Products and all subsequent assemblies and parts:

Required multi-level report with BOM levels shown for each assembly/part:

I am led to believe this could be achieved with either VBA or Power Pivot, but any other method will of course be appreciated.

Many thanks in advance.

 

[Andy Howcroft]

I don’t have much time at the moment, unfortunately

No worries, if you get chance in the near future it would be greatly appreciated as without the data we are unable to proceed with our ERP implementation - thanks.

 

[kevin9999]

Have you considered Mr Excel Consulting Services?
Consulting Services

 

[JEC]

I am close to another recursive solution, but have to find time to finish it. Have some more patience

 

[JEC]

Andy, here my solution.

Referring to my previous post with the table in it; paste the table in A1 before you run this.
This solution is based on an object loaded TreeView. First, everything is loaded into the Treeview, after which the data is extracted directly from this object, instead of looping over and over.
You will notice that this method is a lot faster, but more complicated.

Place the code in an empty module.

Dim aBom, TV, xp, x As Long
Sub jec()
 Dim dic As Object, TV As Object, ar, it, j As Long
 ar = Sheets("Data").Cells(1).CurrentRegion
 x = 0
 Set dic = CreateObject("scripting.dictionary")
 Set TV = GetObject("New:{9181DC5F-E07D-418A-ACA6-8EEA1ECB8E9E}")   'Object loaded treeview
   
 For j = 2 To UBound(ar)
    If Not dic.exists(ar(j, 1)) Then
       dic(ar(j, 1)) = Empty
       TV.Nodes.Add , , ar(j, 1), ar(j, 1)
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    Else
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    End If
 Next
        
 ReDim aBom(1 To 50000, 1 To 9)
 For Each it In dic.keys
    xp = it
    GetBom TV.Nodes(it), 1
 Next
  
 Sheets("Data").Range("m1").Resize(, 9) = Array("Lvl", "Item", "Seq", "Stepname", "LineNr", "CodeType", "Description", "Unit", "Qty")
 Sheets("Data").Cells(2, 13).Resize(x, 9) = aBom
End Sub


Sub GetBom(it, iLvL)
 Dim sp, j As Long, c As Long
 For j = 1 To it.Children
    If j = 1 Then Set it1 = it.Child
    If j > 1 Then Set it1 = it1.Next
    sp = Split(it1, "^^")
    If sp(0) = xp Then
       x = x + 1
       aBom(x, 1) = iLvL
       aBom(x, 2) = sp(0)
       aBom(x + 1, 1) = iLvL + 1
       aBom(x + 1, 2) = Space(iLvL * 10) & sp(5)
       x = x + 1
       xp = ""
    Else
       x = x + 1
       aBom(x, 1) = iLvL + 1
       aBom(x, 2) = Space(iLvL * 10) & sp(5)
    End If
    For c = 2 To 8
       aBom(x, c + 1) = sp(IIf(c > 5, c, c - 1))
    Next
    On Error Resume Next
    Set ab = TV.Nodes(sp(5))
    If Err = 0 Then GetBom TV.Nodes(sp(5)), iLvL + 1
    On Error GoTo 0
 Next
End Sub

 

[JEC]

Sorry, I had a double declaration. This is the correct one

Dim aBom, TV, xp, x As Long
Sub jec()
 Dim dic As Object, ar, it, j As Long
 ar = Sheets("Data").Cells(1).CurrentRegion
 x = 0
 Set dic = CreateObject("scripting.dictionary")
 Set TV = GetObject("New:{9181DC5F-E07D-418A-ACA6-8EEA1ECB8E9E}")   'Object loaded treeview
  
 For j = 2 To UBound(ar)
    If Not dic.exists(ar(j, 1)) Then
       dic(ar(j, 1)) = Empty
       TV.Nodes.Add , , ar(j, 1), ar(j, 1)
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    Else
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    End If
 Next
       
 ReDim aBom(1 To 50000, 1 To 9)
 For Each it In dic.keys
    xp = it
    GetBom TV.Nodes(it), 1
 Next
 
 Sheets("Data").Range("m1").Resize(, 9) = Array("Lvl", "Item", "Seq", "Stepname", "LineNr", "CodeType", "Description", "Unit", "Qty")
 Sheets("Data").Cells(2, 13).Resize(x, 9) = aBom
End Sub


Sub GetBom(it, iLvL)
 Dim sp, tbl, j As Long, c As Long
 For j = 1 To it.Children
    If j = 1 Then Set it1 = it.Child
    If j > 1 Then Set it1 = it1.Next
    sp = Split(it1, "^^")
    If sp(0) = xp Then
       x = x + 1
       aBom(x, 1) = iLvL
       aBom(x, 2) = sp(0)
       aBom(x + 1, 1) = iLvL + 1
       aBom(x + 1, 2) = Space(iLvL * 10) & sp(5)
       x = x + 1
       xp = ""
    Else
       x = x + 1
       aBom(x, 1) = iLvL + 1
       aBom(x, 2) = Space(iLvL * 10) & sp(5)
    End If
    For c = 2 To 8
       aBom(x, c + 1) = sp(IIf(c > 5, c, c - 1))
    Next
    On Error Resume Next
    Set tbl = TV.Nodes(sp(5))
    If Err = 0 Then GetBom tbl, iLvL + 1
    On Error GoTo 0
 Next
End Sub

 

[Andy Howcroft]

Sorry, I had a double declaration. This is the correct one

Dim aBom, TV, xp, x As Long
Sub jec()
 Dim dic As Object, ar, it, j As Long
 ar = Sheets("Data").Cells(1).CurrentRegion
 x = 0
 Set dic = CreateObject("scripting.dictionary")
 Set TV = GetObject("New:{9181DC5F-E07D-418A-ACA6-8EEA1ECB8E9E}")   'Object loaded treeview
 
 For j = 2 To UBound(ar)
    If Not dic.exists(ar(j, 1)) Then
       dic(ar(j, 1)) = Empty
       TV.Nodes.Add , , ar(j, 1), ar(j, 1)
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    Else
       TV.Nodes.Add ar(j, 1), 4, ar(j, 6) & j, Join(Application.Index(ar, j), "^^")
    End If
 Next
      
 ReDim aBom(1 To 50000, 1 To 9)
 For Each it In dic.keys
    xp = it
    GetBom TV.Nodes(it), 1
 Next
 
 Sheets("Data").Range("m1").Resize(, 9) = Array("Lvl", "Item", "Seq", "Stepname", "LineNr", "CodeType", "Description", "Unit", "Qty")
 Sheets("Data").Cells(2, 13).Resize(x, 9) = aBom
End Sub


Sub GetBom(it, iLvL)
 Dim sp, tbl, j As Long, c As Long
 For j = 1 To it.Children
    If j = 1 Then Set it1 = it.Child
    If j > 1 Then Set it1 = it1.Next
    sp = Split(it1, "^^")
    If sp(0) = xp Then
       x = x + 1
       aBom(x, 1) = iLvL
       aBom(x, 2) = sp(0)
       aBom(x + 1, 1) = iLvL + 1
       aBom(x + 1, 2) = Space(iLvL * 10) & sp(5)
       x = x + 1
       xp = ""
    Else
       x = x + 1
       aBom(x, 1) = iLvL + 1
       aBom(x, 2) = Space(iLvL * 10) & sp(5)
    End If
    For c = 2 To 8
       aBom(x, c + 1) = sp(IIf(c > 5, c, c - 1))
    Next
    On Error Resume Next
    Set tbl = TV.Nodes(sp(5))
    If Err = 0 Then GetBom tbl, iLvL + 1
    On Error GoTo 0
 Next
End Sub

Thanks so much for looking into this again. I am having the below issue, though, when I run it. I can get out 25,000 of the original single BOM level report but then it errors. Would it be helpful to send through my the original file to test on...?

 

[JEC]

Set the redim line to

ReDim aBom(1 To 500000, 1 To 9)

 

[Andy Howcroft]

Set the redim line to

ReDim aBom(1 To 500000, 1 To 9)

I already tried that (well, to 400,000)

 

[JEC]

while debugging, what is the value of “x” then?

 

[Andy Howcroft]

while debugging, what is the value of “x” then?

I don't know how to find that out; is it just easier if I send you the single BOM file and you can test it yourself, happy to do so....