Sub demBoTrung()
Dim ar(), i As Integer, lr As Integer, dic1, dic2
Dim kq(), k, idx
lr = Range("A" & Rows.Count).End(3).Row
ar = Range("A2:B" & lr).Value
ReDim kq(1 To UBound(ar), 1 To 2)
Set dic1 = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For i = 1 To UBound(ar)
If Not dic1.exists(ar(i, 1)) Then
k = k + 1
dic1.Add ar(i, 1), k
kq(k, 1) = ar(i, 1)
End If
If Not dic2.exists(ar(i, 1) & ar(i, 2)) Then
dic2.Add ar(i, 1) & ar(i, 2), ""
idx = dic1.Item(ar(i, 1))
kq(idx, 2) = kq(idx, 2) + 1
End If
Next
If k Then
Range("F11").Resize(k, 2) = kq
End If
End Sub
