Option Explicit
Sub D_I_C()
'//Khai bao bien(tham so)
Dim data(), res1(), res2(), res3()
Dim sNgayTruoc As String, sNgaySau As String, sKey As String
Dim r As Long, iK As Long, k1 As Long, k2 As Long, k3 As Long
'//Khoi tao DIC
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
'// thuc hien tren sheet co ten la DATA cua chinh file chay code nay
With ThisWorkbook.Worksheets("DATA")
'// xac dinh dong cuoi trong bang du lieu tu cot C:I, lay dong cuoi trong cot C
r = .Cells(.Rows.Count, "C").End(xlUp).Row
'// neu dong cuoi < 4 khong co du lieu, thoat thu tuc
If r < 4 Then
'// Thong bao khong tim thay du lieu
MsgBox "Khong tim thay du lieu dau vao", vbCritical + vbOKOnly, "Kiem tra lai"
'/Thoat thu tuc
Exit Sub
End If
'// Gan du lieu vao mang data
data = .Range("C4:I" & r).Value
'//khai bao kich thuoc cho cac mang ket qua voi chieu thu nhat = mang data, chieu thu 2 = 3 cot
ReDim res1(1 To UBound(data, 1), 1 To 3)
ReDim res2(1 To UBound(data, 1), 1 To 3)
ReDim res3(1 To UBound(data, 1), 1 To 3)
'// duyet vong lap trong mang data bat dau tu can duoi (LBound) den can tren (UBound) so do du lieu
'//VONGLAP 1: Dua ngay/ma/ten vao DIC
For r = LBound(data, 1) To UBound(data, 1)
'//Ghep ngay/ma/ten tao thanh Key(dieu kien)
sKey = data(r, 1) & "|" & data(r, 3) & "|" & data(r, 4)
'//Dua ngay/ma/ten vao DIC
If Not dic.Exists(sKey) Then dic.Add sKey, r
Next r
'//Lap lai vong lap tren
'//VONGLAP 2: Kiem tra su LOGIC
For r = LBound(data, 1) To UBound(data, 1)
'// Xac dinh key voi ngay "1/1/2020"/Ma/Ten
sNgayTruoc = .Range("K3") & "|" & data(r, 3) & "|" & data(r, 4)
'// Xac dinh key voi ngay "1/30/2020"/Ma/Ten
sNgaySau = .Range("O3") & "|" & data(r, 3) & "|" & data(r, 4)
'// Neu Key cho ngay "1/1/2020" da ton tai thi lay
If dic.Exists(sNgayTruoc) Then
'// Neu Key cho ngay "1/30/2020" khong ton tai hoac khong lay key (ma/Ten) cua ngay sau.
If Not dic.Exists(sNgaySau) Then
'//Tao key tam them "#Res1#" de phan biet su khac nhau voi các KEY gan vao tai vong lap 1
sKey = "#Res1#" & sNgayTruoc
'// neu chua ton tai Key
If Not dic.Exists(sKey) Then
k1 = k1 + 1 '// Moi lan xuat hien Key moi se tang len 1
dic.Add sKey, k1 'Gan Key vao DiC & ghi nho thu tu (chi dong) cua mang Res1
res1(k1, 1) = data(r, 3) '//Ma
res1(k1, 2) = data(r, 4) '//Ten
res1(k1, 3) = data(r, 7) '//Gia tri
Else '// Neu key moi tai
iK = dic.Item(sKey) '//lay ra(xac dinh) so dong (thu tu) da ghi nho K1 o tren
res1(iK, 3) = res1(iK, 3) + data(r, 7) '// Cong don vao dong thu tu tim duoc trong mang resr1
End If
End If
End If
'// Neu Key cho ngay "1/1/2020" khong ton tai hoac co ton tai thi bo qua
If Not dic.Exists(sNgayTruoc) Then
'// Neu Key cho ngay "1/30/2020" da ton tai thi lay
If dic.Exists(sNgaySau) Then
'//Tao key tam them "#Res2#" de phan biet su khac nhau voi các KEY gan vao tai vong lap 1 va vong lap gan key cho Res1 ? tren
sKey = "#Res2#" & sNgayTruoc
If Not dic.Exists(sKey) Then '//Tuong tu o tren
k2 = k2 + 1
dic.Add sKey, k2
res2(k2, 1) = data(r, 3)
res2(k2, 2) = data(r, 4)
res2(k2, 3) = data(r, 7)
Else
iK = dic.Item(sKey)
res2(iK, 3) = res2(iK, 3) + data(r, 7)
End If
End If
End If
If dic.Exists(sNgayTruoc) Then '// Neu Key cho ngay "1/1/2020" ton tai
If dic.Exists(sNgaySau) Then '// Neu Key cho ngay "1/30/2020"
'//Tao key tam them "#Res3#" de phan biet su khac nhau voi cac key da gan vao DIC
sKey = "#Res3#" & sNgayTruoc
If Not dic.Exists(sKey) Then '//Tuong tu o tren
k3 = k3 + 1
dic.Add sKey, k3
res3(k3, 1) = data(r, 3)
res3(k3, 2) = data(r, 4)
res3(k3, 3) = data(r, 7)
Else
iK = dic.Item(sKey)
res3(iK, 3) = res3(iK, 3) + data(r, 7)
End If
End If
End If
Next r
'//Tu K5 quet xuong duoi 1000 dong va quet sang phai 11 cot roi xoa du lieu cu
.Range("K5").Resize(1000, 11).ClearContents
'//Gan ket qua tung mang xuong tung vung tren bang tinh
If k1 > 0 Then .Range("K5").Resize(k1, 3).Value = res1 '// ket qua ngay truoc
If k2 > 0 Then .Range("O5").Resize(k2, 3).Value = res2 '// ket qua ngay sau
If k3 > 0 Then .Range("S5").Resize(k3, 3).Value = res3 '// ket qua chung
End With
'// Giai phong (xoa dic) DIC
Set dic = Nothing
'// Thong bao da xu ly xong
MsgBox "OK, xong", vbInformation + vbOKOnly, "Ket thuc."
End Sub
