BOM (Bill of Materials) Explosion

Dear all,

First time poster here but long time lurker!

I am attempting to undertake an analysis of a multi level (~6 level) bill of materials. The BOM list contains approx. 22,000 records detailing the part number, lower level part number and Qty required (amongst other data not relevant to discussion).

I wish to take a list of parts (approx. 150) and quiz the BOM to tell me the required quantities at each level in the BOM - i.e. make a Kit List of parts that I would require to make the 150 top level items. I do NOT require to know which part is associated with which lower level part.

For example...

Bill of materials

Part Feeder Qty
A B 1
B C 2
B D 2
C Y 5
C Z 10
G H 2
H I 1
H J 2
J K 0.5
J D 1

So to “Explode”

L0 L1 L2 L3
A B (1 per)
C (2 per)
Y (5 per)
Z (10 per)
D (2 per)
G H (2 per)
I (1 per)
J (2 per)
K (0.5 per)
D (1 per)

I wish to be able to “plug in” a list of parts and sales Qtys (sales Items) and get out a “usage” of materials

Parts List
Sales Item Qty
A 10
G 5

Usage Figs
A 10 =10
B (10*1) =10
C (10*1*2) =20
D (10*1*2) + (5*2*2*1) =40
G 5 =5
H (5*2) =10
I (5*2*1) =10
J (5*2*2) =20
K (5*2*2*0.5) =10
Y (10*1*2*5) =100
Z (10*1*2*10) =200

My data on the BOM will be from a ODBC connection to a table.

I have seen several items about "recursive macros" but I do not understand them!

If you require further explanation then please let me know. I need a solution that will work in Excel 2010 and 2013. Thanks in advance

Andy

Thanks for the prompt reply.

I have tried some code but it does not do what I require - it appears to be failing when it is looking through a range of BOM containing 21000 records. The code used is..

(hope I get this right!)

Sub GetQuantities()

' Turn screen update off
    Application.ScreenUpdating = False
    
Const ModelCol = "A"
Const ModelQntyCol = "B"
Const ParentCol = "F"
Const Childcol = "G"
Const ChildQuantCol = "H"
Const ModelOutCol = "O"
Const PartCol = "P"
Const PartQntCol = "Q"


Const StartDataRow = 3
SummaryRowCount = StartDataRow

Lastrow = Range(ParentCol & Rows.Count).End(xlUp).Row

Set ParentRange = Columns(ParentCol)
Set ChildRange = Columns(Childcol)
Set TopLevelPart = Columns(ModelCol)

For RowCount = StartDataRow To Lastrow
  Child = Range(Childcol & RowCount)
  'Check if child is lowest level part by search through parent column
  Set c = ParentRange.Find(what:=Child, LookIn:=xlValues, lookat:=xlWhole)
  If c Is Nothing Then
   ChildQuant = Range(ChildQuantCol & RowCount)
   'part is lowest level part
   'now search for all parents
   PartParent = Range(ParentCol & RowCount)
   
   'loop until part is found as another parent
   Do
     Set c = ChildRange.Find(what:=PartParent, LookIn:=xlValues, lookat:=xlWhole)
     If Not c Is Nothing Then
      Quant = Range(ChildQuantCol & c.Row)
      ChildQuant = ChildQuant * Quant
      PartParent = Range(ParentCol & c.Row)
     End If
   Loop While Not c Is Nothing
   
   'Parent should now contain a top level part
   'search for top level part
   Set c = TopLevelPart.Find(what:=PartParent, LookIn:=xlValues, lookat:=xlWhole)
   If c Is Nothing Then
   '  MsgBox ("Cannot find top Level Part : " & PartParent)
   Else
     Quant = Range(ModelQntyCol & c.Row)
     ChildQuant = ChildQuant * Quant
     Range(ModelOutCol & SummaryRowCount) = PartParent
     Range(PartCol & SummaryRowCount) = Child
     Range(PartQntCol & SummaryRowCount) = ChildQuant
     SummaryRowCount = SummaryRowCount + 1
   End If
  End If

Next RowCount

' Turn screen update off
    Application.ScreenUpdating = True
End Sub

This created the 4th table from the left - I have tried to calculate the result that I want as well (Third table from Left)

Hope this helps
Andy

Dear all,

I have found an alternative piece of code with "Mr Google" from https://social.msdn.microsoft.com/Fo...forum=exceldev by Charles Excel MVP The Excel Calculation Site http://www.decisionmodels.com/

With some tweaks it is working better than my original post however I have some issues with the data output.

the code is :

'18/3
Sub p_Start()

 Dim rSearch As Range
 Dim rAssemblies As Range
 Dim lLastrow As Long
 Dim OutPutArray As Variant

 '
 ' NOTE: the Bill of Materials must be sorted ascending on parent and Child
 '
 ' Bill of materials is in columnds D:E, work out the search range
 lLastrow = Range("D" & Rows.Count).End(xlUp).Row
 Set rSearch = Range("D3").Resize(lLastrow - 2, 3)

 ' Cycle through all top level assemblies & use recursive rotuine to get to lowest levels
 lLastrow = Range("A" & Rows.Count).End(xlUp).Row
 Set rAssemblies = Range("A3").Resize(lLastrow - 2, 2)

' additional output options so that you can get  - change x
' unique lists of final components (OutType=2) or top and final pairs(OutType=3) or the full list (outType=1)
' OutPutArray = ExplodeBOM3(rAssemblies, rSearch, x)
 OutPutArray = ExplodeBOM3(rAssemblies, rSearch, 2)

 p_OutPutToSheet OutPutArray

End Sub
Sub p_OutPutToSheet(OutPutArray As Variant)

' Output the top level parent and the lowest level part(s)

 Range("I3").Resize(UBound(OutPutArray, 1), UBound(OutPutArray, 2)) = OutPutArray

End Sub
Public Function ExplodeBOM3(TopDemand As Range, BOM As Range, OutType As Long) As Variant
 Dim vOut() As Variant

 Dim vIn As Variant
 Dim jOut As Long
 Dim j As Long
 Dim RequdQty As Long
 
 ' Dim jOut As Single
 'Dim j As Single
 'Dim RequdQty As Single
 
 
 Dim strParent As String
 Dim strTop As String


 'On Error GoTo FuncErr
 '
 ' initialise output array
 '
 ReDim vOut(1 To 3, 1 To 100)

 vIn = TopDemand.Value2
 If Not IsArray(vIn) Then GoTo FuncErr
 '
 ' process each top-level input
 '
 For j = 1 To UBound(vIn)
 If vIn(j, 2) > 0 Then
  RequdQty = vIn(j, 2)
  strTop = Trim(CStr(vIn(j, 1)))
  strParent = strTop
  If Len(strTop) = 0 Then Exit For
  GetParentChild strTop, strParent, BOM, RequdQty, vOut(), jOut
 End If
 Next j

 ReDim Preserve vOut(1 To 3, 1 To jOut)
 ExplodeBOM3 = CreateOutput(vOut, OutType)
 Exit Function
FuncErr:
 ExplodeBOM3 = CVErr(xlErrNA)
End Function
Function CreateOutput(vOut() As Variant, OutType As Long) As Variant
 Dim j As Long
 Dim k As Long
 Dim vOut2() As Variant
 Dim strPair As String
 Dim vItem As Variant

 Dim OutDict As New Scripting.Dictionary

 Select Case OutType
 Case 2
 '
 ' unique end components
 '
 For j = 1 To UBound(vOut, 2)
  If Len(Trim(vOut(2, j))) = 0 Then Exit For
  If OutDict.Exists(vOut(2, j)) Then
  OutDict.Item(vOut(2, j)) = OutDict.Item(vOut(2, j)) + vOut(3, j)
  Else
  OutDict.Add vOut(2, j), vOut(3, j)
  End If
 Next j
 j = 0
 ReDim vOut2(1 To OutDict.Count, 1 To 3)
 For Each vItem In OutDict
  j = j + 1
  vOut2(j, 1) = vItem
  vOut2(j, 2) = OutDict(vItem)
 Next vItem
 CreateOutput = vOut2
 Case 3
 '
 ' unique pairs
 '
 k = 0
 For j = 1 To UBound(vOut, 2)
  If Len(Trim(vOut(1, j))) = 0 Then Exit For
  strPair = vOut(1, j) & "|" & vOut(2, j)
  If OutDict.Exists(strPair) Then
  OutDict.Item(strPair) = OutDict.Item(strPair) + vOut(3, j)
  Else
  OutDict.Add strPair, vOut(3, j)
  End If
 Next j
 j = 0
 ReDim vOut2(1 To OutDict.Count, 1 To 3)
 For Each vItem In OutDict
  j = j + 1
  strPair = vItem
  k = InStr(strPair, "|")
  vOut2(j, 1) = Left(strPair, k - 1)
  vOut2(j, 2) = Right(strPair, Len(strPair) - k)
  vOut2(j, 3) = OutDict(vItem)
 Next vItem
 CreateOutput = vOut2
 Case Else
 '
 ' full list
 '
 CreateOutput = Application.Transpose(vOut)
 End Select
End Function
Sub GetParentChild(strTop As String, strParent As String, BOM As Range, Qty As Long, vOut() As Variant, jOut As Long)
 Dim vRow As Variant
 Dim rngParent As Range
 Dim vData As Variant
 Dim nParents As Long
 Dim j As Long
 Dim blFound As Boolean
 Dim ChildQty As Long

 blFound = False
 '
 ' Assume BOM is sorted ascending on Parent
 '
 Set rngParent = BOM.Resize(, 1)
 vRow = Application.Match(strParent, rngParent, True)

 If IsError(vRow) Then
 '
 ' parent does not exist
 '
 Else
 'If strParent <> Trim(CStr(rngParent.Cells(CLng(vRow), 1).Value2)) Then
 '' :) If strParent <> Trim(CStr(rngParent.Cells(CDbl(vRow), 1).Value2)) Then
 If strParent <> Trim(CStr(rngParent.Cells(CDbl(vRow), 1).Value2)) Then
  '
  ' no exact match found
  '
 Else
  blFound = True
  '
  ' get all BOM data for this parent
  '
  nParents = Application.CountIf(rngParent, "=" & strParent)
  'vData = BOM.Offset(CLng(vRow) - nParents, 0).Resize(nParents, 3).Value2
  vData = BOM.Offset(CDbl(vRow) - nParents, 0).Resize(nParents, 3).Value2
  For j = 1 To nParents
  '
  ' recurse each child for this parent
  '
  strParent = Trim(CStr(vData(j, 2)))
'   ChildQty = Qty * CLng(vData(j, 3))
  ChildQty = Qty * CDbl(vData(j, 3))

  GetParentChild strTop, strParent, BOM, ChildQty, vOut(), jOut
  Next j
 End If
 End If

 If Not blFound Then
 '
 ' store Results
 '
 jOut = jOut + 1
 If jOut > UBound(vOut, 2) Then
  ReDim Preserve vOut(1 To 3, 1 To UBound(vOut, 2) * 2)
 End If
 vOut(1, jOut) = strTop
 vOut(2, jOut) = strParent
 vOut(3, jOut) = Qty
 End If
End Sub

The problems that I am having are...
1) not listing all items on the BOM explosion - only the lowest level items
I do not understand the recursive method so not sure what it is doing!

2) The calculation is "Rounding" (or trimming) the result - When I have 4dp BOM qtys I need 4DP answers.
I suspect that it may be a "variable as an integer" but when I don't understand the code fully (i.e. less than 25%) then I do not know where to start looking.

For example the 03414 part consumes 0.1838 of LF5564143
for 1 off 0.1838 ......I see 0
for 10 off 1.838 ......I see 2
for 100 off 18.38 .....I see 18
for 1000 off 183.8 ....I see 184
for 10000 off 1838 ...I see 1838

I will also upload a revised sheet.