Option Explicit
Sub MakeList()
'Written by Tran Quang Hai, 0908247563
Dim i As Long, j As Long, k As Long, kk As Long, sh As Worksheet
Dim dArr(), sArr(), Res(), Pcs As Long, Qty As Long, Dic As Object, tmp As String, x As Long
Set Dic = CreateObject("scripting.Dictionary")
Set sh = Sheets("Packing_List")
With Sheets("Order_Qty")
sArr = .Range("A1", .[A65536].End(3)).Resize(, 200).Value
End With
ReDim Res(1 To 10000, 1 To UBound(sArr, 2) + 5)
ReDim dArr(1 To 10000, 1 To UBound(sArr, 2) + 5)
For i = 5 To UBound(sArr)
For j = 3 To 12
If IsNumeric(sArr(i, j)) Then
If sArr(i, j) > 0 Then
k = k + 1
Res(k, 4) = sArr(i, 1)
Res(k, 5) = sArr(i, 2)
Res(k, j + 3) = sArr(i, j)
End If
End If
Next
Next
sh.[A16].Resize(k, UBound(Res, 2)) = Res
For i = 1 To k
For j = 6 To 15
Pcs = sArr(3, j - 3)
Qty = Res(i, j)
Do While Qty >= Pcs 'per box
kk = kk + 1
dArr(kk, 4) = Res(i, 4) 'style
dArr(kk, 5) = Res(i, 5) 'color
dArr(kk, j) = Pcs
Qty = Qty - Pcs
If Qty > 0 And Pcs > Qty Then
kk = kk + 1
dArr(kk, 4) = Res(i, 4) 'style
dArr(kk, 5) = Res(i, 5) 'color
dArr(kk, j) = Qty
End If
Loop
Next
Next
sh.[A16].Resize(10000, UBound(dArr, 2)).ClearContents
sh.[A16].Resize(10000, UBound(dArr, 2)).Interior.ColorIndex = xlNone
k = 0
For i = 1 To kk
For j = 6 To 15
If dArr(i, j) > 0 Then
tmp = dArr(i, 4) & dArr(i, 5) & dArr(i, j) & sArr(2, j - 3)
tmp = UCase(tmp)
dArr(i, 16) = dArr(i, j)
dArr(i, 18) = "=RC[-1]*RC[-2]"
If Not Dic.exists(tmp) Then
Dic.Add tmp, i
dArr(i, 17) = 1
Else
x = Dic.item(tmp)
dArr(x, 17) = dArr(x, 17) + 1
End If
If dArr(i, 16) > 21 Then
dArr(i, 20) = "0.59*0.4*0.23"
Else
dArr(i, 20) = "0.59*0.4*0.115"
End If
End If
Next
Next
For i = 1 To kk
If dArr(i, 17) > 0 Then
k = k + 1
For j = 1 To UBound(dArr, 2)
dArr(k, j) = dArr(i, j)
Next
If i = 1 Then
dArr(k, 1) = 1
dArr(k, 3) = dArr(k, 17)
Else
dArr(k, 1) = dArr(k - 1, 3) + 1
dArr(k, 3) = dArr(k, 1) + dArr(k, 17) - 1
End If
End If
Next
sh.[A16].Resize(k, UBound(dArr, 2)) = dArr
End Sub
