Sub aTest()
Dim dic As Object, vData As Variant, i As Long
Dim vKey As Variant, lNumItems As Long, strItem As String
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
'Stores values in the dictionary
For i = LBound(vData) To UBound(vData)
If dic.exists(vData(i, 1)) Then
dic(vData(i, 1))(vData(i, 2)) = Empty
dic(vData(i, 1))(vData(i, 3)) = Empty
Else
Set dic(vData(i, 1)) = CreateObject("Scripting.Dictionary")
dic(vData(i, 1))(vData(i, 2)) = Empty
dic(vData(i, 1))(vData(i, 3)) = Empty
End If
Next i
'Transfer values to worksheet beginning in G2
i = 1
For Each vKey In dic.keys
If dic(vKey).Count > lNumItems Then lNumItems = dic(vKey).Count
i = i + 1
Range("G" & i).Resize(, dic(vKey).Count) = dic(vKey).keys
Next vKey
'Headers
Range("F1") = "CHAR"
Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
For i = 1 To lNumItems
strItem = "LIST-B"
If i Mod 2 = 1 Then strItem = "LIST-A"
If i > 2 Then strItem = strItem & Int((i - 1) / 2)
Range("G1").Offset(, i - 1) = strItem
Next i
End SubSub aTestV2()
Dim dic As Object, vData As Variant, i As Long, spl As Variant
Dim vKey As Variant, lNumItems As Long, strItem As String
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
vData = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row)
'Stores values in the dictionary
For i = LBound(vData) To UBound(vData)
dic(vData(i, 1)) = dic(vData(i, 1)) & "," & vData(i, 2) & "," & vData(i, 3)
Next i
'Transfer values to worksheet beginning in G2
i = 1
For Each vKey In dic.keys
spl = Split(Mid(dic(vKey), 2), ",")
If UBound(spl) + 1 > lNumItems Then lNumItems = UBound(spl) + 1
i = i + 1
Range("G" & i).Resize(, UBound(spl) + 1) = spl
Next vKey
'Headers
Range("F1") = "CHAR"
Range("F2").Resize(dic.Count) = Application.Transpose(dic.keys)
For i = 1 To lNumItems
strItem = "LIST-B"
If i Mod 2 = 1 Then strItem = "LIST-A"
If i > 2 Then strItem = strItem & Int((i - 1) / 2)
Range("G1").Offset(, i - 1) = strItem
Next i
End Sub
