Sub Cau2Dic1()
Dim T As Double
T = Timer
Dim endR&, i&, s&, nR&
Dim Tmp1$
Dim Arr(), ArrKq()
Dim Dic1 As Object
Set Dic1 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
endR = .Cells(65000, 1).End(3).Row
Arr = .Range("B2:G" & endR).Value
End With
ReDim ArrKq(1 To UBound(Arr), 1 To 8)
For i = 1 To UBound(Arr)
If Len(Arr(i, 1)) > 0 Then
If Len(Arr(i, 2)) > 0 Then
Tmp1 = Arr(i, 1) & Arr(i, 2)
If Not Dic1.exists(Tmp1) Then
s = s + 1
Dic1.Add Tmp1, s
ArrKq(s, 1) = Arr(i, 1)
ArrKq(s, 2) = Arr(i, 2)
End If
nR = Dic1.Item(Tmp1)
Select Case Len(Arr(i, 3))
Case Is > 0
If Len(ArrKq(nR, 7)) = 0 Then
ArrKq(nR, 7) = Arr(i, 3) 'Add vao
ArrKq(nR, 3) = ArrKq(nR, 3) + 1
ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
Else
If InStr(ArrKq(nR, 7), Arr(i, 3)) Then
ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
Else
ArrKq(nR, 7) = ArrKq(nR, 7) & Arr(i, 3) 'Add vao
ArrKq(nR, 3) = ArrKq(nR, 3) + 1
ArrKq(nR, 5) = ArrKq(nR, 5) + Arr(i, 6)
End If
End If
Case Is = 0
If Len(ArrKq(nR, 8)) = 0 Then
ArrKq(nR, 8) = Arr(i, 4) 'Add vao
ArrKq(nR, 4) = ArrKq(nR, 4) + 1
ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
Else
If InStr(ArrKq(nR, 8), Arr(i, 4)) Then
ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
Else
ArrKq(nR, 8) = ArrKq(nR, 8) & Arr(i, 4) 'Add vao
ArrKq(nR, 4) = ArrKq(nR, 4) + 1
ArrKq(nR, 6) = ArrKq(nR, 6) + Arr(i, 6)
End If
End If
End Select
End If
End If
Next i
If s > 0 Then
With Sheets("Cau2")
With .[A4]
.Resize(60000, 6).ClearContents
.Resize(s, 6) = ArrKq
End With
.[I3] = Timer - T
End With
End If
Erase Arr(), ArrKq()
Set Dic1 = Nothing
End Sub
