prima:
aaa	abc, cou, zdf, suh
aaa	cdu, icf, oid, ncu
aaa	abc, cou, zdf, suh
aaa	hbc, oid, zdf, iom, ngo, kodl
bbb	xcf, iopm, poia, iund, zd
bbb	hft, kjp, lop, mas, òdl
bbb	poim, lop, mas, ild, zop
bbb	ghdf, lop, poin, lku
bbb	xcf, iopm, poia, iund, zd
ccc	ocf, ccf, zcf
ccc	ocf, ccf, zcf
ccc	dcf, zcf, ncf

e vorrei che diventasse dopo così:
aaa	abc, cou, zdf, suh; cdu, icf, oid, ncu; hbc, oid, zdf, iom, ngo, kodl
bbb	xcf, iopm, poia, iund, zd; hft, kjp, lop, mas, òdl; poim, lop, mas, ild, zop; ghdf, lop, poin, lku
ccc	ocf, ccf, zcf; dcf, zcf, ncf

Option Explicit

Sub estrapola()
Dim table As Range, ac As Range, ac2 As Range, coll As Collection, s As String, v As Variant, i As Integer
   
    [A1].CurrentRegion.Resize([A1].CurrentRegion.Rows.Count - 1, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[D1], Unique:=True
    
    On Error Resume Next
    
    Set table = [D1].CurrentRegion.Resize([D1].CurrentRegion.Rows.Count - 1, 1).Offset(1)
    For Each ac In table
        Set coll = New Collection
        s = ""
        For Each ac2 In [A1].CurrentRegion.Rows
            If ac = ac2.Cells(1) Then coll.Add ac2.Cells(2), ac2.Cells(2)
        Next
        For Each v In coll
            s = s & v & ";"
        Next
        i = i + 1
        [A23].Offset(i) = ac
        [B23].Offset(i) = Replace(s & "@", ";@", "")
    Next
    
    On Error GoTo 0
    
    [D1].CurrentRegion.Delete
    
End Sub

Option Explicit

Sub estrapola()
Dim ac As Range, coll As Collection, s As String, v As Variant, i As Integer
Dim unique_values As Collection, vv As Variant
   
    On Error Resume Next
    
    Set unique_values = New Collection
    Set unique_values = collection_of_duplicates([A1].CurrentRegion.Resize([A1].CurrentRegion.Rows.Count - 1, 1))
    
    For Each v In unique_values
        Set coll = New Collection
        s = ""
        [A1].AutoFilter field:=1, Criteria1:=v
 
        For Each ac In [A1].CurrentRegion.SpecialCells(xlCellTypeVisible).Rows
            coll.Add ac.Cells(2), ac.Cells(2)
        Next
        For Each vv In coll
            s = s & vv & ";"
        Next
        i = i + 1
        [A23].Offset(i) = v
        [B23].Offset(i) = Replace(s & "@", ";@", "")
    Next
    
    [A1].AutoFilter
    On Error GoTo 0

End Sub


Function collection_of_duplicates(vettore As Variant) As Collection
Dim v As Variant, dups As Collection
    
    Set dups = New Collection
    On Error Resume Next
    For Each v In vettore
        dups.Add CStr(v), v
    Next
    On Error GoTo 0
    Set collection_of_duplicates = dups
End Function

Option Explicit

Sub estrapola()
Dim table As Range, ac As Range, coll As Collection, v As Variant, i As Integer
Dim unique_values As Collection, vv As Variant, destination As Range, z As Range
Dim iCharFrom As Integer, iCharLength As Integer, j As Integer, s As String
   
Dim color_table() As Variant
    
    color_table = Array(3, 4, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 25)   '21 colori diversi
    
    Set table = [A1].CurrentRegion.Resize([A1].CurrentRegion.Rows.Count - 1, 1).Offset(1)
    Set unique_values = New Collection
    Set unique_values = collection_of_duplicates(table)
    
    [D:E].Font.ColorIndex = xlAutomatic
    [D:E].ClearContents
    
    On Error Resume Next
    i = 0
    
    For Each v In unique_values
        Set coll = New Collection
        For Each z In table.Resize(, 1)
            If v = z Then coll.Add z.Offset(, 1), z.Offset(, 1)
        Next
        
        [D1].Offset(i) = v
        Set destination = [e1].Offset(i)
        
        For Each vv In coll
            destination = destination & vv & ";"
        Next
        destination = Left(destination, Len(destination) - 1)
        
        j = 0
        For Each vv In coll
            iCharFrom = InStr(destination, vv)
            iCharLength = iCharFrom + Len(vv)
            [e1].Offset(i).Characters(Start:=iCharFrom, Length:=iCharLength).Font.ColorIndex = color_table(j)
            j = j + 1
        Next
        
        i = i + 1
    Next
    
    On Error GoTo 0

End Sub


Function collection_of_duplicates(vettore As Variant) As Collection
Dim v As Variant, dups As Collection
    
    Set dups = New Collection
    On Error Resume Next
    For Each v In vettore
        dups.Add CStr(v), v
    Next
    On Error GoTo 0
    Set collection_of_duplicates = dups
End Function