Sub GPE()
Dim sArr(), d(), Res(), Tong(), Dic As Object
Dim i As Long, eRow As Long, j As Byte, jCol As Byte, n As Byte, ik As Byte
Dim Nam As Integer, Thang As Byte, ThangStr As String, Tuan As Byte
Dim iKey As String, S As Double
With Sheets("24.12")
eRow = .Range("B1000000").End(xlUp).Row
If eRow > 13 Then .Range("B14:V" & eRow).ClearContents
.Range("B4:C11").ClearContents
Nam = .Range("T13").Value
Thang = .Range("U13").Value
ThangStr = Format(DateSerial(1, Thang, 1), "mmm")
Tuan = .Range("V13").Value
End With
ReDim Tong(1 To 8, 1 To 4)
With Sheets("Data")
eRow = .Range("C1000000").End(xlUp).Row
If eRow < 2 Then Exit Sub
sArr = .Range("C2:S" & eRow).Value
End With
ReDim Res(1 To UBound(sArr), 1 To 21)
Set Dic = Nothing
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sArr)
iKey = sArr(i, 17)
S = sArr(i, 13)
If sArr(i, 1) = Nam And sArr(i, 2) = Thang And sArr(i, 3) = Tuan Then
If Not Dic.Exists(iKey) Then
n = n + 1
Dic.Add iKey, n
Tong(n, 1) = iKey
End If
ik = Dic.Item(iKey)
Tong(ik, 2) = Tong(ik, 2) + S
k = k + 1
For j = 1 To 17
If j < 11 Then jCol = j Else jCol = j + 1
Res(k, jCol) = sArr(i, j)
Next j
End If
Next i
For i = 1 To UBound(sArr)
If sArr(i, 1) = Nam Then
iKey = sArr(i, 17)
S = sArr(i, 13)
If Dic.Exists(iKey) Then
ik = Dic.Item(iKey)
Tong(ik, 3) = Tong(ik, 3) + S
If sArr(i, 2) = Thang Then Tong(ik, 4) = Tong(ik, 4) + S
End If
End If
Next i
With Sheets("24.12")
If k > 0 Then
For i = 1 To k
Res(i, 2) = ThangStr
ik = Dic.Item(Res(i, 18))
Res(i, 19) = Tong(ik, 3)
Res(i, 20) = Tong(ik, 4)
Res(i, 21) = Tong(ik, 2)
Next i
.Range("B14").Resize(k, 21) = Res
.Range("B4").Resize(Dic.Count, 2) = Tong
End If
End With
End Sub