Sub XYZ()
Dim arr(), a, b(), res(), dic As Object
Dim sRow&, sCol&, i&, SoHo&, k&, ik&, t&, j&, key$, tong#
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = 1
arr = Range("B6", Range("E" & Rows.Count).End(xlUp)).Value
sRow = UBound(arr)
LamLai:
SoHo = 0: k = 0
dic.RemoveAll
sCol = sCol + 10 'Mot ho co nhieu nhat 10 Thua
ReDim b(1 To sRow, -1 To sCol)
ReDim res(1 To sRow * 2 + 1, 1 To 5)
For i = 1 To sRow
key = Trim(arr(i, 1))'Loai Khoang Trang
If dic.exists(key) = False Then
SoHo = SoHo + 1
dic.Add key, SoHo
b(SoHo, -1) = key
End If
t = dic(key)
key = key & "|" & arr(i, 3)
If dic.exists(key) = False Then
b(t, 0) = b(t, 0) + 1
If b(t, 0) > sCol Then GoTo LamLai 'Mot ho co nhieu hon sCol Thua
dic.Add key, Array(arr(i, 2), arr(i, 4))
b(t, b(t, 0)) = key
Else
a = dic(key)
a(0) = a(0) & ";" & arr(i, 2)
a(1) = a(1) + arr(i, 4)
dic(key) = a
End If
Next i
For i = 1 To SoHo
k = k + 1
res(k, 1) = i
res(k, 2) = b(i, -1)
ik = k
For j = 1 To sCol
If b(i, j) = Empty Then Exit For
k = k + 1
res(k, 3) = dic(b(i, j))(0)
res(k, 4) = Split(b(i, j), "|")(1)
res(k, 5) = dic(b(i, j))(1)
res(ik, 5) = res(ik, 5) + res(k, 5)
Next j
tong = tong + res(ik, 5)
Next i
i = Range("K" & Rows.Count).End(xlUp).Row
If i > 5 Then Range("G6:K" & i).ClearContents
If k Then
k = k + 1
res(k, 5) = tong
Range("G6").Resize(k, 5) = res
End If '
End Sub
