Option Explicit
Sub Thong_Ke()
Dim Ws As Worksheet
Dim i&, R&, C%, ID$, K&, CODE$, Rws&, Col&
Dim Dic As Object
Dim DL(), KQ()
Set Dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------
With Sheet1
DL = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, 19).Value
R = UBound(DL)
ReDim KQ(3 To R, 1 To 18)
For i = 3 To UBound(DL)
ID = Trim(DL(i, 1))
If Not Dic.exists(ID) Then Dic.Add ID, i
Next
For i = 2 To UBound(DL, 2)
CODE = Trim(DL(1, i))
If Not Dic.exists(CODE) Then Dic.Add CODE, i - 1
Next
End With
For Each Ws In ActiveWorkbook.Worksheets
If Ws.CodeName <> "Sheet1" Then
With Ws
C = .Range("XFD4").End(xlToLeft).Column - 2
DL = .Range("C5", .Range("C" & Rows.Count).End(xlUp)).Resize(, C).Value
For i = 1 To UBound(DL)
ID = Trim(DL(i, 1))
CODE = Trim(DL(i, 6))
If Dic.exists(ID) Then
If Dic.exists(CODE) Then
Col = Dic.Item(CODE)
K = Dic.Item(ID)
KQ(K, Col) = KQ(K, Col) + DL(i, 8)
End If
End If
Next
End With
End If
Next
Set Dic = Nothing
Sheet1.Range("C5").Resize(R - 2, 18).ClearContents
Sheet1.Range("C5").Resize(R - 2, 18) = KQ
Sheet1.Range("C5").Resize(R - 2, 18).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
