Sub TONGHOP()
Dim Arr(), KQ(), TieuDe()
Dim I&, J&, k&, t&, R&, Lr&
Dim DK, DK2, Dic As Object
With Sheet1
Lr = .Cells(Rows.Count, 2).End(xlUp).Row
Arr = .Range("A2:C" & Lr).Value
R = UBound(Arr)
ReDim TieuDe(1 To 1, 1 To Lr)
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To Lr - 1
If Arr(I, 2) <> "" Then DK2 = Trim(Arr(I, 2))
If Not Dic.Exists(DK2) Then
k = k + 1
Dic.Add (DK2), k
TieuDe(1, k) = DK2
End If
Next I
ReDim KQ(1 To R, 1 To k + 1)
For I = 1 To R
If Arr(I, 1) <> "" Then DK = Arr(I, 1)
If Not Dic.Exists(DK) Then
t = t + 1
Dic.Add (DK), t
KQ(t, 1) = DK
End If
Next I
Dim Rng As Range
Set Rng = .Range("A1:A" & Lr)
On Error Resume Next
For J = 1 To UBound(KQ)
dong = Rng.Find(KQ(J, 1)).Row
If KQ(J + 1, 1) <> "" Then
dongcuoi = Rng.Find(KQ(J + 1, 1)).Row - 1
Else
dongcuoi = Lr
End If
For Z = dong To dongcuoi
keys = Arr(Z - 1, 2)
If Dic.Exists(keys) Then
KQ(J, Dic.Item(keys) + 1) = Arr(Z - 1, 3)
End If
Next Z
Next J
End With
Sheet2.[F15].Resize(t, k + 1) = KQ
Sheet2.[G14].Resize(1, k) = TieuDe
MsgBox "Xong"
End Sub
(
