Option Explicit
Sub DieuChinh()
Dim sh As Worksheet, dic As Object, dic2 As Object
Dim arr(), S, S2, res(), aDC()
Dim sRow&, tRow&, i&, j&, r&, r2&, k&, SL#, tSL#, key
Const srDC& = 1000 'Gioi han so dong hien thi ket qua dieu chinh, tang them neu can thiet
ReDim aDC(1 To srDC, 1 To 4)
Set sh = Sheet1
arr = sh.Range("A3:G" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 1)
Set dic = CreateObject("scripting.dictionary") 'Dieu chinh giam
Set dic2 = CreateObject("scripting.dictionary") 'Dieu chinh tang
For i = 1 To sRow
res(i, 1) = arr(i, 6)
arr(i, 1) = arr(i, 6) - arr(i, 4)
If arr(i, 1) > 0 Then
dic(arr(i, 3)) = dic(arr(i, 3)) & "," & i 'Dieu chinh giam
ElseIf arr(i, 1) < 0 Then
dic2(arr(i, 3)) = dic2(arr(i, 3)) & "," & i 'Dieu chinh tang
arr(i, 1) = -arr(i, 1)
End If
Next i
For Each key In dic.keys
S = Split(dic(key), ",")
S2 = Split(dic2(key), ",")
For i = 1 To UBound(S)
r = CLng(S(i))
SL = arr(r, 1)
For j = 1 To UBound(S2)
r2 = CLng(S2(j))
If arr(r2, 1) > 0 Then
If arr(r2, 1) >= SL Then
res(r, 1) = res(r, 1) - SL
res(r2, 1) = res(r2, 1) + SL
tSL = SL
arr(r2, 1) = arr(r2, 1) - SL
SL = 0
Else
res(r, 1) = res(r, 1) - arr(r2, 1)
res(r2, 1) = res(r2, 1) + arr(r2, 1)
tSL = arr(r2, 1)
SL = SL - arr(r2, 1)
arr(r2, 1) = 0
End If
k = k + 1
If k <= srDC Then
aDC(k, 1) = key
aDC(k, 2) = arr(r, 2)
aDC(k, 3) = arr(r2, 2)
aDC(k, 4) = tSL
End If
End If
If SL = 0 Then Exit For
Next j
Next i
Next key
sh.Range("I3").Resize(sRow) = res
i = sh.Range("K" & Rows.Count).End(xlUp).Row
If i > 2 Then sh.Range("K3:N" & i).ClearContents
If k Then sh.Range("K3").Resize(k, 4) = aDC
End Sub
)
