BOM (Bill of Materials) Explosion

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.