Sub AutoCountClient()
Dim R1 As Range, R2 As Range
Dim NRw As Long, NCln As Long, Sp1 As Long, Sp2 As Long, i As Long, j As Long
'Vung chua cac Ma SP
Set R1 = Range("C2:C" & Range("C1000000").End(xlUp).Row)
'Dem so dong cua vung
NRw = R1.Rows.Count
'Xoa du lieu ket qua cu
Range("O2:P500").ClearContents
ReDim Arr(1 To NRw, 1 To 100)
'Tach cac Ma SP tung dong duoc phan cach boi dau phay (,)
For Each R2 In R1
i = i + 1
For Sp1 = 1 To Len(R2.Value)
If Mid(R2, Sp1, 1) = "," Then
j = j + 1
Arr(i, j) = Trim(Mid(R2, Sp2 + 1, Sp1 - Sp2 - 1))
Sp2 = Sp1
ElseIf Sp1 = Len(R2) Then
j = j + 1
Arr(i, j) = Trim(Mid(R2, Sp2 + 1, Sp1 - Sp2))
End If
Next Sp1
If NCln < j Then NCln = j
Sp1 = 0: Sp2 = 0: j = 0
Next
'Ghi ket qua Ma SP da tach
Range("D2").Resize(NRw, NCln).Value = Arr
Dim Dic1 As Object, irow As Long, icln As Long, k As Long
Dim Arr2() As Variant, TmpArr As Variant
Set Dic1 = CreateObject("Scripting.Dictionary")
'Chep ket qua Ma SP vao mang trung gian
TmpArr = Range(Cells(2, 4), Cells(NRw + 1, NCln + 3)).Value
ReDim Arr2(1 To 100, 1 To 2)
'Dem so luong Ma SP theo thong tin Client cell O1
For irow = 1 To UBound(TmpArr, 1)
If Cells(irow + 1, 2) = Range("O1") Then
For icln = 1 To NCln
If Not IsEmpty(TmpArr(irow, icln)) And Not Dic1.Exists(TmpArr(irow, icln)) Then
k = k + 1
Dic1.Add TmpArr(irow, icln), k
Arr2(k, 1) = TmpArr(irow, icln)
Arr2(k, 2) = 1
Else
On Error Resume Next
Arr2(Dic1.Item(TmpArr(irow, icln)), 2) = Arr2(Dic1.Item(TmpArr(irow, icln)), 2) + 1
On Error GoTo 0
End If
Next icln
End If
Next irow
'Ghi ket qua cuoi cung vao cell O2
Range("O2").Resize(k, 2).Value = Arr2
End Sub
