Sub XYZ()
Dim i&, j&, k&, Lr&, R&, C&, DongTong&, M&
Dim Arr(), KQ(), HT(), CONG()
Dim Tu As Date, Den As Date
Dim Key, Tmp, Keys
Dim Dic As Object, DicH As Object, DicChuyen As Object
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("0219")
Lr = Sh.Cells(Rows.Count, 2).End(3).Row
Arr = Sh.Range("B6:G" & Lr).Value
R = UBound(Arr)
Set DicChuyen = CreateObject("Scripting.Dictionary")
For i = 1 To R
If Not DicChuyen.Exists(Arr(i, 1)) Then n = n + 1: DicChuyen.Add (Arr(i, 1)), n
Next i
Set Ws = Sheets("STD")
Ld = Ws.Cells(Rows.Count, 2).End(3).Row
ArrN = Ws.Range("B4:I" & Ld).Value
Set DicH = CreateObject("Scripting.Dictionary")
ReDim HT(1 To UBound(ArrN), 1 To 2)
For i = 1 To UBound(ArrN)
Tmp = ArrN(i, 1) & "|" & ArrN(i, 7)
If Not DicH.Exists(Tmp) Then
k = k + 1: DicH.Add (Tmp), k
HT(k, 1) = ArrN(i, 1)
HT(k, 2) = ArrN(i, 8)
End If
Next i
Set WsS = Sheets("summary")
C = WsS.Cells(2, Columns.Count).End(xlToLeft).Column
WsS.Cells(4, 1).Resize(1000, C).ClearContents
WsS.Cells(4, 1).Resize(1000, C).Font.Bold = False
For Each Keys In DicChuyen.Keys
Set Rng = WsS.Range("B2").CurrentRegion
irow = Rng.Rows.Count + 1
WsS.Cells(irow, 1) = Keys
ReDim CONG(1 To 1, 1 To C)
For j = 2 To C Step 5
ReDim KQ(1 To R, 1 To 5)
Tu = CDate(WsS.Cells(2, j + 1)) - 1
Den = CDate(WsS.Cells(2, j + 4)) + 1
t = 0
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
If CDate(Arr(i, 4)) > Tu And CDate(Arr(i, 4)) < Den Then
If Arr(i, 1) = Keys Then
Key = Arr(i, 1) & Arr(i, 2)
M = WsS.[G1]
Temp = Arr(i, 2) & "|" & WsS.[G1]
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
KQ(t, 1) = Arr(i, 2)
KQ(t, 2) = Arr(i, 6)
KQ(t, 3) = Arr(i, 3)
KQ(t, 4) = Arr(i, 5)
If DicH.Exists(Temp) Then
KQ(t, 5) = HT(DicH.Item(Temp), 2)
Else
For ii = 1 To UBound(ArrN, 1)
If ArrN(ii, 1) = Arr(i, 2) Then
If Abs(ArrN(ii, 7) - WsS.[G1]) < M Then
M = Abs(ArrN(ii, 7) - WsS.[G1])
KQ(t, 5) = ArrN(ii, 8)
End If
End If
Next ii
End If
Else
k = Dic.Item(Key)
KQ(k, 3) = KQ(k, 3) + Arr(i, 3)
End If
End If
End If
Next i
If t Then
WsS.Cells(irow, j).Resize(t, 5) = KQ
CONG(1, j) = "Total"
CONG(1, j + 1) = Application.Sum(WsS.Cells(irow, j + 2).Resize(t))
CONG(1, j + 2) = Application.Sum(WsS.Cells(irow, j + 3).Resize(t)) / t
CONG(1, j + 3) = Application.Max(WsS.Cells(irow, j + 4).Resize(t))
End If
Set Dic = Nothing
Next j
Set Rng = WsS.Range("B2").CurrentRegion
erow = Rng.Rows.Count + 1
WsS.Cells(erow, 2).Resize(1, C) = CONG
WsS.Cells(erow, 1).Resize(1, C).Font.Bold = True
Next Keys
Set DicH = Nothing
Set DicChuyen = Nothing
MsgBox "Xong", vbInformation, "THONG BÁO"
End Sub
