XL 2016 Regrouper cellule selon critere commun

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

Private Sub Worksheet_Activate()
  Set f = Sheets("Fichier de Base")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("a1:b" & f.[a65000].End(xlUp).Row).Value
  For i = 1 To UBound(Tbl)
  d1(Tbl(i, 1)) = d1(Tbl(i, 1)) & Tbl(i, 2) & vbCrLf
  Next i
  [A2].Resize(d1.Count) = Application.Transpose(d1.keys)
  [b2].Resize(d1.Count) = Application.Transpose(d1.items)
End Sub

  [b2].Resize(d1.Count) = Application.Transpose(d1.items)

Private Sub Worksheet_Activate()
  Set f = Sheets("Fichier de Base")
  Set d1 = CreateObject("Scripting.Dictionary")
  TblE = f.Range("a1:b" & f.[a65000].End(xlUp).Row).Value
  For i = 1 To UBound(TblE)
    d1(TblE(i, 1)) = d1(TblE(i, 1)) & TblE(i, 2) & vbCrLf
  Next i
  [A2].Resize(d1.Count) = Application.Transpose(d1.keys)   ' 65000 clés maxi
  TblItems = d1.items: ReDim TblItems2(1 To d1.Count, 1 To 1)
  For i = 1 To d1.Count: TblItems2(i, 1) = TblItems(i - 1): Next i
  [b2].Resize(d1.Count) = TblItems2
End Sub