Fusionner contenu de x lignes si le contenu de la 1ère colonne est identique

Private Sub Worksheet_Activate()
Dim ncol%, tablo, resu(), d As Object, i&, x$, n&, nn&, j%
With Feuil1.[A1].CurrentRegion 'à adapter
    ncol = .Columns.Count
    If ncol < 2 Then ncol = 2 'au moins 2 colonnes
    tablo = .Resize(, ncol) 'matrice, plus rapide
End With
ReDim resu(1 To UBound(tablo), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(tablo)
    x = tablo(i, 1) & Chr(1) & tablo(i, 2)
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise la ligne
        resu(n, 1) = tablo(i, 1)
        resu(n, 2) = tablo(i, 2)
    End If
    nn = d(x)
    For j = 3 To ncol
        resu(nn, j) = IIf(resu(nn, j) = "", "", resu(nn, j) & vbLf) & tablo(i, j)
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] 'cellule à adapter
    With .Resize(n, ncol)
        .Value = resu
        .ColumnWidth = 255
        .WrapText = True 'renvoi à la ligne
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .EntireColumn.AutoFit 'ajustement largeur
    End With
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise les barres de défilement
End Sub