Sub XYZ()
Dim aData(), aDH(), Res(), Dic As Object, Mahang, DM&, tmp&, sInt&
Dim r&, i&, k&, iR&, j&, sRow&
Application.ScreenUpdating = False
With Sheet4 'Sheets Data
aData = .Range("C3", .Range("F" & Rows.Count).End(xlUp)).Value
End With
With Sheet2 'Sheet Don Hang
i = .Range("A" & Rows.Count).End(xlUp).Row
Res = .Range("A2:E" & i).Value
.Range("A2:E" & i).Sort .[A2], 1, .[C2], , 1
aDH = .Range("A2:E" & i + 1).Value
.Range("A2:E" & i).Value = Res
End With
Set Dic = CreateObject("Scripting.Dictionary")
sRow = UBound(aData, 1)
For i = 1 To sRow
Dic.Item(aData(i, 1)) = aData(i, 4)
Next i
sRow = UBound(aDH, 1) - 1
ReDim Res(1 To sRow * 2, 1 To 8)
For i = 1 To sRow
DM = Dic.Item(aDH(i, 3))
If aDH(i, 5) >= DM Then
k = k + 1
'Res(k, 1) = k
Res(k, 2) = aDH(i, 1): Res(k, 3) = aDH(i, 2)
Res(k, 4) = aDH(i, 3): Res(k, 5) = aDH(i, 4)
Res(k, 6) = DM
Res(k, 7) = Int(aDH(i, 5) / DM)
Res(k, 8) = DM * Res(k, 7)
aDH(i, 5) = aDH(i, 5) - Res(k, 8)
End If
Next i
For i = 1 To sRow
If Mahang <> aDH(i, 1) & aDH(i, 3) Then
k = k + 1
Mahang = aDH(i, 1) & aDH(i, 3)
DM = Dic.Item(aDH(i, 3))
For r = i To sRow
If aDH(r, 5) > 0 Then
If Res(k, 1) = Empty Then
Res(k, 1) = k
Res(k, 2) = aDH(r, 1): Res(k, 3) = aDH(r, 2)
Res(k, 4) = aDH(i, 3): Res(k, 5) = aDH(r, 4)
Res(k, 6) = aDH(r, 5): Res(k, 7) = 1
Res(k, 8) = Res(k, 6)
Else
Res(k, 3) = Res(k, 3) & Chr(10) & aDH(r, 2)
Res(k, 5) = Res(k, 5) & Chr(10) & aDH(r, 4)
If Res(k, 8) + aDH(r, 5) >= DM Then
aDH(r, 5) = aDH(r, 5) + Res(k, 8) - DM
Res(k, 6) = Res(k, 6) & Chr(10) & DM - Res(k, 8)
Res(k, 8) = DM
k = k + 1
If aDH(r, 5) > 0 Then r = r - 1
Else
Res(k, 6) = Res(k, 6) & Chr(10) & aDH(r, 5)
Res(k, 8) = Res(k, 8) + aDH(r, 5)
End If
End If
If Mahang <> aDH(r + 1, 1) & aDH(r + 1, 3) Then
i = r
Exit For
End If
End If
Next r
End If
Next i
With Sheet3
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 2 Then .Range("A3:H" & i).Clear
.Range("A3").Resize(k + 1, 8).Value = Res
i = .Range("B" & Rows.Count).End(xlUp).Row
.Range("B3:H" & i).Sort .[B3], 1, .[D3], , 1, .[H3], 2
.Range("A3") = 1
.Range("A3:A" & i).DataSeries
.Range("A3:H" & i).Borders.LineStyle = 1
.Rows("3:" & i).EntireRow.AutoFit
End With
Application.ScreenUpdating = True
End Sub
