Option Explicit
Sub Tong()
Dim i&, j&, Lr&, t&, k&, d&
Dim Arr(), KQ(), Tong(), S
Dim Dic As Object, Key
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("TongHop")
Lr = Sh.Cells(10000, 4).End(xlUp).Row
Arr = Sh.Range("C13:U" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
ReDim KQ(1 To UBound(Arr) + 65, 1 To 21)
For i = 1 To UBound(Arr)
Key = Arr(i, 1)
If Not Dic.exists(Key) Then
t = t + 1: Dic.Add (Key), t
Dic(Key) = i
Else
Dic(Key) = Dic(Key) & "," & i
End If
Next i
ReDim Tong(1 To t, 1 To 21)
For Each Key In Dic.Keys
d = d + 1
S = Split(Dic(Key), ",")
For i = LBound(S) To UBound(S)
k = k + 1
KQ(k, 1) = k: KQ(k, 2) = Arr(S(i), 2): KQ(k, 21) = d: Tong(d, 2) = "Công " & Key
For j = 4 To 16
KQ(k, j - 1) = Arr(S(i), j)
Tong(d, j - 1) = Tong(d, j - 1) + KQ(k, j - 1)
Next j
KQ(k, 16) = Arr(S(i), 19): Tong(1, 16) = Tong(d, 16) + KQ(k, 16)
KQ(k, 17) = KQ(k, 16) * 1800000: Tong(d, 17) = Tong(d, 17) + KQ(k, 17)
KQ(k, 18) = Arr(S(i), 17) * 1800000 * 1.05: Tong(d, 18) = Tong(d, 18) + KQ(k, 18)
KQ(k, 20) = KQ(k, 17) - KQ(k, 18) - KQ(k, 19): Tong(d, 20) = Tong(d, 20) + KQ(k, 20)
Tong(d, 21) = d
Next i
Next Key
If k Then
Set Ws = Sheets("ChiTiet")
Ws.Range("A10").Resize(10000, 21).ClearContents
Ws.Range("A10").Resize(k, 21) = KQ
Ws.Range("A" & Ws.Cells(10000, 2).End(xlUp).Row).Resize(t, 21) = Tong
Ws.Sort.SortFields.Clear
Ws.Sort.SortFields.Add2 Key:=Ws.Range("U10").Resize(k + t), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ChiTiet").Sort
.SetRange Ws.Range("A10").Resize(k + t, 21)
.Apply
End With
Ws.Range("U10").Resize(k + t).ClearContents
End If
Set Dic = Nothing
MsgBox "Done"
End Sub