Here is the Codefor macro. Change the ranges as required.
Sub GetCartoons()
Dim PeriodPeletRng As Range, PeletRng As Range, cel1 As Range, cel2 As Range
Dim Sh As Worksheet
Dim CartonNos As Long, RemPelet As Long, X As Long, Y As Long, K As Long
Dim CartAry()
Set Sh = ActiveSheet
Set PeletRng = Sh.Range("B2:B7")
Set PeriodPeletRng = Sh.Range("E12:E14")
CartAry = WorksheetFunction.Transpose(WorksheetFunction.Transpose(PeletRng))
For Each cel1 In PeriodPeletRng
For Each cel2 In PeletRng
Y = Y + 1
If CartAry(Y, 1) > 0 Then
If RemPelet > 0 Then K = RemPelet Else K = cel1
CartonNos = CartonNos + WorksheetFunction.Ceiling(WorksheetFunction.Min(K, CartAry(Y, 1)) * cel2.Offset(0, 2).Value, 1)
If K > CartAry(Y, 1) Then
RemPelet = K - CartAry(Y, 1)
CartAry(Y, 1) = 0
X = X + 1
Else
CartAry(Y, 1) = CartAry(Y, 1) - K
Exit For
End If
End If
Next cel2
cel1.Offset(0, 1) = CartonNos
CartonNos = 0
RemPelet = 0
Y = 0
Next cel1
End Sub
Bookmarks