Option Explicit
Sub THAYCTHUC()
Dim i&, j&, Lr&, k&, t&, R&, C&
Dim Arr(), COTA(), COTEFG()
Dim Sh As Worksheet, WF As Object
Dim Dic As Object, Key
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set WF = Application.WorksheetFunction
Set Sh = Sheets("Data")
Lr = Sh.Cells(Rows.Count, 2).End(3).Row
Arr = Sh.Range("A2:K" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
ReDim COTA(1 To R, 1 To 1)
ReDim COTEFG(1 To R, 1 To 3)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
COTA(i, 1) = WF.Text(Arr(i, 2), "0") & Arr(i, 3)
If Arr(i, 8) = 0 Or Arr(i, 8) = Empty Then COTEFG(i, 1) = Arr(i, 9) Else COTEFG(i, 1) = Arr(i, 8)
If VBA.Weekday(CDate(Arr(i, 2))) = 1 Then
If Arr(i, 9) > 0 Or Arr(i, 10) > 0 Then COTEFG(i, 2) = "CN1" Else COTEFG(i, 2) = "CN"
Else
If COTEFG(i, 1) > 0 And COTEFG(i, 1) <= 480 Then COTEFG(i, 2) = 1 Else COTEFG(i, 2) = COTEFG(i, 1)
End If
Key = Arr(i, 3)
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
COTEFG(i, 3) = 1
Else
k = Dic.Item(Key)
COTEFG(k, 3) = COTEFG(k, 3) + 1
End If
Next i
Sh.Range("A2").Resize(R, 1) = COTA
Sh.Range("E2").Resize(R, 3) = COTEFG
MsgBox "Xong", vbInformation, "THÔNG BÁO"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
