Sub Run()
Dim MOrder(), LRw As Long, ikey As String
ReDim Result(1 To 50000, 1 To 7)
LRw = [A10000].End(xlUp).Row
MOrder = Range("A4:C" & LRw).Value
'ActiveSheet.Range("F4:L50000").ClearContents
Application.ScreenUpdating = False
With Sheets("Data")
.AutoFilterMode = 0
LastRw = .Cells(50000, 2).End(xlUp).Row
SProduct = .Range("A2:A" & LastRw).Value
Material = .Range("E2:G" & LastRw).Value
SQty = .Range("I2:I" & LastRw).Value
End With
Set Dict1 = CreateObject("scripting.dictionary")
For i = 1 To UBound(SProduct, 1)
'If Not Dict1.exists(SProduct(i, 1)) Then
'Dict1.Add SProduct(i, 1), ""
ikey = SProduct(i, 1)
Dict1.Item(ikey) = Dict1.Item(ikey) & "|" & i
'End If
Next
t = Timer
For i = 1 To UBound(MOrder, 1)
InitialProduct = MOrder(i, 1)
ManufactQty = MOrder(i, 3)
CalculateBOM_2 InitialProduct, ManufactQty
'CalculateBOM InitialProduct, ManufactQty
Next
If m > 0 Then
'ActiveSheet.[F4].Resize(m, 7) = Result
ActiveSheet.[N4].Resize(m, 7) = Result
End If
Erase Material, SQty, SProduct, Result
Set dic1 = Nothing
InitialProduct = "": ManufactQty = 0: m = 0
Application.ScreenUpdating = True
MsgBox Timer - t & " second", , "Ptm0412"
End Sub
Sub CalculateBOM_2(ByVal Product As String, ByVal PrQty As Double)
Dim S As Variant
S = Split(Dict1.Item(Product), "|")
For i = 1 To UBound(S)
j = Val(S(i))
If Not Dict1.exists(CStr(Material(j, 1))) Then
m = m + 1
Result(m, 1) = InitialProduct
Result(m, 2) = ManufactQty
Result(m, 3) = Material(j, 1)
Result(m, 4) = Material(j, 2)
Result(m, 5) = Material(j, 3)
Result(m, 7) = SQty(j, 1) * PrQty
Result(m, 6) = Result(m, 7) / ManufactQty
Else
NewPrqty = SQty(j, 1)
CalculateBOM_2 Material(j, 1), NewPrqty * PrQty
End If
Next i
End Sub
