Option Explicit
Sub ThongKe()
Dim i&, j&, Lr&, t&, k&, Z&, Col&, x&
Dim Arr(), KQ(), S
Dim Dic As Object, Key, Temp
Dim Sh As Worksheet, Ws As Worksheet
Set Ws = Sheets("ChiTietTinh")
Set Sh = Sheets("ThongKe")
Lr = Sh.Cells(100000, 4).End(3).Row
Arr = Sh.Range("A3:F" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
ReDim KQ(1 To 70, 1 To UBound(Arr) + 3)
For i = 2 To UBound(Arr)
k = k + 1
For Col = 4 To 6
If Col = 4 Then
Arr(1, Col) = "DMX"
ElseIf Col = 5 Then
Arr(1, Col) = "NCCK"
ElseIf Col = 6 Then
Arr(1, Col) = "KS"
End If
If Arr(i, Col) <> Empty Then x = InStr(1, Arr(i, Col), "(") Else Exit For
Temp = Mid(Arr(i, Col), x, Len(Arr(i, Col)) - x)
Temp = Replace(Temp, "(", "")
Temp = Replace(Temp, ")", "")
Temp = Replace(Temp, ";", ",")
S = Split(Trim(Temp), ", ")
For j = 0 To UBound(S)
Key = S(j)
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
KQ(t, 1) = t
KQ(t, 3) = Key
KQ(t, k + 3) = Arr(1, Col)
Else
Z = Dic.Item(Key)
KQ(Z, k + 3) = Arr(1, Col)
End If
Next j
Next Col
Next i
If t Then
Ws.Range("K5").Resize(100, 7).ClearContents
Ws.Range("K5").Resize(Dic.Count, 7) = KQ
End If
Set Dic = Nothing
MsgBox "Done"
End Sub
