Mình úp ví dụ 30 dòng code (đoạn không quá bí mật ấy) lên đây xem nào.
Sub testasad()
Dim Dic As Object, Retval(), Tm
Dim eR(), eRmax, Id, I, j
Set Dic = CreateObject("Scripting.Dictionary")
Tm = Sheets("test").Range("a1:b500")
For I = 1 To UBound(Tm, 1)
If Not Dic.exists(Tm(I, 2)) Then
j = j + 1
Dic.Add Tm(I, 2), j
ReDim Preserve eR(1 To j)
eR(j) = 1
ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
Retval(1, j) = Tm(I, 2)
End If
Id = Dic.Item(Tm(I, 2))
eR(Id) = eR(Id) + 1
If eRmax < eR(Id) Then eRmax = eR(Id)
Retval(eR(Id), Id) = Tm(I, 1)
Next
Sheets("test").Range("a1:b500").ClearContents
Sheets("test").Range("M3").Resize(eRmax, UBound(Retval, 2)) = Retval
Set Dic = Nothing
End Sub