Help to calculate "Bill of Material" for products in nested layers...

Hi !

Got a really tricky logic to crack.

Keeping it short: I need to calculate how much rawmaterial that is required to produce a product. In this exmaple the E product.
However, The E Product is not composed of only rawmaterials (would be easy to sum up) but is composed of other refined products that is composed of other refined products that all have a mix of the rawmaterials.

Please see attached excel.
This kind of nested "Bill of Material" of products makes it difficult to calculate the core rawmaterial required.
I have tried to make it easy in the excel for the example.

There is a:
- Conversion table ----- SEE S6
- An input Table of what I want to produce ----- SEE B10
- and the Output (result) table ----- SEE I10 where all of this should calculate how many "rawmaterials" required.

How can this be solved with formulas or perhaps a data model ?

see attached example excel:


Much appreciate this support and tough nut to crack.

Production tables.xlsx

In concept it is (or appears to be) very similar to this ..

https://www.excelforum.com/excel-for...-bom-cost.html

how many variants are there of the Realtion table i.e how many finished products / how many material products (given the latter can include the former) ?

Give this a try: my results differ from yours: see sheet1 for my interpretation of the logic.

Sub Get_Materialsx()
Dim pAr, rAr, rpAr, wkAr, rTabl, ipar

pAr = Range("Products")
rAr = Range("Raw_Materials")
rpAr = Range("Refined_Product")
opar = Range("Output_Products")
ipar = Range("Input_Products")
rtbl = Range("Relation_Tbl")

ReDim wkAr(1 To UBound(rAr))

For i = 1 To UBound(rAr, 1)
    wkAr(i) = 0
Next i

i = Application.Match(rpAr(1, 1), opar, 0)  ' Position of start of "Defined Product" in "Relation Table"
Debug.Print "ptr", "i", "Key", "mv", "mtype", "wkAr(1)", "wkAr(2)", "j", "rtbl(j, 3)"
If Not IsError(i) Then
    j = 0
    Do While opar(i, 1) = rpAr(1, 1) ' Loop for all occurences of Defined Product
        j = j + 1
        Key = rtbl(i, 2)
        mv = rtbl(i, 3)

        j = Application.Match(Key, rAr, 0) ' Is this a raw material ?
        If Not IsError(j) Then
           mtype = "RM"
           mv = 1
           Else
               j = Application.Match(Key, opar, 0) ' Is this a raw material ?
               If Not IsError(j) Then
                  mtype = "RT"
                  Key = rtbl(j, 1)
               End If
        End If
        
        'ptr = "(1)"
       ' Debug.Print ptr, i, Key, mv, mtype, wkAr(1), wkAr(2)
        
        Select Case mtype
        
        Case Is = "RM"  ' Raw material
            
            For k = 1 To UBound(rAr, 1)
                If Key = rAr(k, 1) Then
                  wkAr(k) = wkAr(k) + rtbl(j, 3) * mv
                  Exit For
                End If
            Next k
         'ptr = "(2)"
        ' Debug.Print ptr, i, Key, mv, mtype, wkAr(1), wkAr(2), j, rtbl(j, 3)
        Case Is = "RT"  '
        
Do_again:
            Do While rtbl(j, 1) = Key
            
                For k = 1 To UBound(rAr, 1)
                    If rtbl(j, 2) = rAr(k, 1) Then
                      wkAr(k) = wkAr(k) + rtbl(j, 3) * mv
                      j = j + 1
                      GoTo loop_Again
                    End If
                Next k
               ' ptr = "(3)"
               ' Debug.Print ptr, i, Key, mv, mtype, wkAr(1), wkAr(2), j, rtbl(j, 3)
                 'mType = "RT"
                 Key = rtbl(j, 2)
                 j = Application.Match(Key, ipar, 0) ' Is this a raw material ?
                 If Not IsError(j) Then
                 ' mType = "RT"
                  mv = mv * rtbl(j, 3)
                  Key = rtbl(j, 2)
                  j = Application.Match(Key, opar, 0) ' Is this a raw material ?
                End If
               ' ptr = "(4)"
               ' Debug.Print ptr, i, Key, mv, mtype, wkAr(1), wkAr(2), j, rtbl(j, 3)
                GoTo Do_again
                
loop_Again:
           Loop
               
               
exit_Select:
        End Select
        
        i = i + 1
        If i > UBound(rtbl, 1) Then Exit Do
    Loop
    
End If

[A37] = wkAr(1) * Range("Refined_Product")(1, 2)
[a38] = wkAr(2) * Range("Refined_Product")(1, 2)
End Sub

I have used named ranges so if this works then you need to provide a sample of how your real data is formatted.