Option Explicit
Sub ChamCong()
Dim arr(), aNgay(), aCNV(), aCo$(), aCo2(), aCh(), dic As Object, dic2 As Object
Dim sR&, i&, r&, j&, jC&, key$
'******* Tinh Sheet Cong
Set dic = CreateObject("scripting.dictionary") 'Dic sheet cong
Set dic2 = CreateObject("scripting.dictionary") 'Dic sheet Check cong
With Sheet3 'Sheet Cong
arr = .Range("B2:H" & .Range("B" & Rows.Count).End(xlUp).Row).Value
End With
sR = UBound(arr)
ReDim aCo(1 To sR, 1 To 1)
ReDim aCo2(1 To sR, 1 To 3)
For i = 1 To sR
aCo(i, 1) = CLng(arr(i, 1)) & arr(i, 2)
If arr(i, 4) = 0 Then aCo2(i, 1) = arr(i, 5) Else aCo2(i, 1) = arr(i, 4)
dic.Item(arr(i, 2)) = dic.Item(arr(i, 2)) + 1
If arr(i, 1) = DateValue("2022/04/09") Then
If arr(i, 4) > 0 Or arr(i, 5) > 0 Then aCo2(i, 2) = "CN1" Else aCo2(i, 2) = "CN"
Else
If arr(i, 1) = DateValue("2022/04/10") Then
If aCo2(i, 1) > 0 And aCo2(i, 1) <= 480 Then aCo2(i, 2) = 1 Else aCo2(i, 2) = aCo2(i, 1)
Else
If Weekday(arr(i, 1)) = 1 Then
If arr(i, 4) > 0 Or arr(i, 5) > 0 Then aCo2(i, 2) = "CN1" Else aCo2(i, 2) = "CN"
Else
If aCo2(i, 1) > 0 And aCo2(i, 1) <= 480 Then aCo2(i, 2) = 1 Else aCo2(i, 2) = aCo2(i, 1)
End If
End If
End If
If dic2.exists(arr(i, 2)) = False Then dic2.Item(arr(i, 2)) = arr(i, 3) 'Ho ten
dic2.Item(aCo(i, 1)) = aCo2(i, 2) 'Thu tu dòng
Next i
For i = 1 To sR
aCo2(i, 3) = dic.Item(arr(i, 2))
Next i
Sheet3.Range("A2").Resize(sR, 1) = aCo 'Sheet Cong
Sheet3.Range("I2").Resize(sR, 3) = aCo2 'Sheet Cong
'******* Tinh Sheet Check Cong
dic.RemoveAll
With Sheet4 'Sheet CBCNV
aCNV = .Range("A3:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
For i = 1 To UBound(aCNV)
dic.Item(aCNV(i, 1)) = i
Next i
With Sheet1 'Sheet Check Cong
arr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
aNgay = .Range("B1:AS1").Value
End With
sR = UBound(arr)
ReDim aCh(1 To sR, 1 To 55)
dic2.Add 1, 33 'Add thu tu cot
dic2.Add "P", 45: dic2.Add "N", 45: dic2.Add "S", 45: dic2.Add "F", 45
For j = 34 To 44
dic2.Add aNgay(1, j), j
Next j
For i = 1 To sR
If dic2.exists(arr(i, 1)) Then aCh(i, 1) = dic2.Item(arr(i, 1)) 'cot 1
For j = 2 To 32
key = CLng(aNgay(1, j)) & arr(i, 1)
If dic2.exists(key) Then
aCh(i, j) = dic2.Item(key) 'cot 2 den 32
jC = dic2.Item(aCh(i, j)) 'cot 33 den 45
If jC > 0 Then
aCh(i, jC) = aCh(i, jC) + 1 'cot 33 den 45
aCh(i, 55) = aCh(i, 55) + 1 'cot 55
End If
If aCh(i, j) = "CN1" Then aCh(i, 49) = aCh(i, 49) + 1 'cot 49
If aCh(i, j) = 1 Or aCh(i, j) = "A/2" Then aCh(i, 50) = aCh(i, 50) + 1 'cot 50
End If
Next j
r = dic.Item(arr(i, 1))
If r > 0 Then
For j = 51 To 54 'cot 51 den 54
aCh(i, j) = aCNV(r, j - 48)
Next j
End If
Next i
For i = 1 To sR
aCh(i, 46) = aCh(i, 38) / 2 + aCh(i, 39) + aCh(i, 40) / 2 'cot 46
For j = 41 To 45
aCh(i, 47) = aCh(i, 47) + aCh(i, j) 'cot 47
Next j
For j = 33 To 40
aCh(i, 48) = aCh(i, 48) + aCh(i, j) 'cot 48
Next j
aCh(i, 49) = aCh(i, 49) + aCh(i, 33) + aCh(i, 38) 'cot 49
Next i
Sheet1.Range("B2").Resize(sR, 55) = aCh 'Sheet Check Cong
End Sub
