Private Sub Worksheet_Activate()
Dim L#, tablo, d As Object, i&, x$, a, b, c$()
With Feuil1 'CodeName de la feuille
.Columns(2).AutoFit 'ajustement largeur
L = .Columns(2).ColumnWidth
tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
End With
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
x = tablo(i, 1)
d(x) = d(x) & IIf(d.exists(x), vbLf, "") & tablo(i, 2)
Next
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
Columns(2).ColumnWidth = 66 'à adapter
'---transposition---
a = d.keys: b = d.items
ReDim c(UBound(a), 1) 'base 0
For i = 0 To UBound(c): c(i, 0) = a(i): c(i, 1) = b(i): Next
'---restitution---
Columns(2).WrapText = True 'renvoi à la ligne
Columns(2).ColumnWidth = L
[A1].Resize(i, 2) = c
End Sub