Sub XetTrung()
Dim sArr(), Res(), Dic As Object
Dim eRow&, sRow&, j&, i&, r&, tmp$, d As Double
Dim stt$, stt2$, kVuc$, Tram$, May$, fTime, eTime
Application.ScreenUpdating = False
With Sheets("Check")
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
.Range("A2:R" & eRow).Sort .[E2], 1, Header:=xlYes
sArr = .Range("A3:F" & eRow).Value
End With
Set Dic = CreateObject("scripting.dictionary")
sRow = UBound(sArr)
ReDim Res(1 To sRow, 1 To 12)
For i = 1 To sRow - 1
stt = sArr(i, 1): kVuc = sArr(i, 2): Tram = sArr(i, 3)
May = sArr(i, 4): fTime = sArr(i, 5): eTime = sArr(i, 6)
If fTime < eTime Then
For r = i + 1 To sRow
If sArr(r, 5) < eTime Then
If sArr(r, 5) < sArr(r, 6) Then
If sArr(r, 3) = Tram Then j = 1 Else j = 7
If sArr(r, 4) <> May Then j = j + 3
stt2 = sArr(r, 1)
If sArr(r, 2) = kVuc Or j <> 10 Then
If j = 4 Then
tmp = Dic.Item(stt) & ","
If InStr(1, tmp, "," & sArr(r, 4) & ",") = 0 Then
Res(i, j) = Res(i, j) + 1
Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 4)
End If
tmp = Dic.Item(stt2) & ","
If InStr(1, tmp, "," & sArr(i, 4) & ",") = 0 Then
Res(r, j) = Res(r, j) + 1
Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 4)
End If
ElseIf j = 7 Then
tmp = Dic.Item(stt) & ","
If InStr(1, tmp, "," & sArr(r, 3) & ",") = 0 Then
Res(i, j) = Res(i, j) + 1
Dic.Item(stt) = Dic.Item(stt) & "," & sArr(r, 3)
End If
tmp = Dic.Item(stt2) & ","
If InStr(1, tmp, "," & sArr(i, 3) & ",") = 0 Then
Res(r, j) = Res(r, j) + 1
Dic.Item(stt2) = Dic.Item(stt2) & "," & sArr(i, 3)
End If
Else
Res(i, j) = Res(i, j) + 1
Res(r, j) = Res(r, j) + 1
End If
If Len(Res(i, j + 1)) Then
If Len(Res(i, j + 1)) < 250 Then Res(i, j + 1) = Res(i, j + 1) & ", " & sArr(r, 1) 'Gioi han so ky tu ket qua
Else
Res(i, j + 1) = sArr(r, 1)
End If
If Len(Res(r, j + 1)) Then
If Len(Res(r, j + 1)) < 250 Then Res(r, j + 1) = Res(r, j + 1) & ", " & sArr(i, 1)
Else
Res(r, j + 1) = sArr(i, 1)
End If
If sArr(r, 6) < eTime Then d = sArr(r, 6) - sArr(r, 5) Else d = eTime - sArr(r, 5)
Res(i, j + 2) = Res(i, j + 2) + d
Res(r, j + 2) = Res(r, j + 2) + d
End If
End If
Else
Exit For
End If
Next r
End If
Next i
With Sheets("Check")
.Range("G3").Resize(sRow, 12).Value = Res
.Range("A2:R" & eRow).Sort .[A2], 1, Header:=xlYes
End With
Erase sArr: Erase Res
Application.ScreenUpdating = True
End Sub
