Réorganisation de valeurs dans un tableur : help please !

Sub Regrouper()
Dim dico As New Dictionary, t, i&, n&, elem

  With Sheets("Feuil1")
    Application.ScreenUpdating = False
    t = Range("a1:b" & .Cells(.Rows.Count, "a").End(xlUp).Row)
    For i = 1 To UBound(t)
      If Not dico.Exists(t(i, 1)) Then dico.Add t(i, 1), New Dictionary
      n = n + 1: dico(t(i, 1)).Add n, t(i, 2)
    Next i
    .Range("e1").CurrentRegion.Clear
    i = 0
    For Each elem In dico
      .Range("e1").Offset(i) = elem
      .Range("e1").Offset(i, 1).Resize(, dico(elem).Count) = dico(elem).Items
      i = i + 1
    Next elem
  End With
End Sub

Sub Traitement_doublons()
Dim F As Worksheet, dest As Range, tablo, d As Object, i&, x$
Set F = Feuil1 'CodeName de la feuille, à adapter
Set dest = F.[d2] 'à adapter
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest.EntireColumn.Resize(, F.Columns.Count - dest.Column).ClearContents 'RAZ
tablo = F.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.dictionary")
For i = 2 To UBound(tablo)
    x = CStr(tablo(i, 1))
    If Not d.exists(x) Then d(x) = tablo(i, 1)
    d(x) = d(x) & " " & tablo(i, 2)
Next
If d.Count = 0 Then Exit Sub
dest.Resize(d.Count) = Application.Transpose(d.items) 'Transpose limitée à 65536 lignes
dest.Resize(d.Count).TextToColumns dest, xlDelimited, Space:=True 'commande Convertir
End Sub

Sub Traitement_doublons()
Dim F As Worksheet, dest As Range, tablo, d As Object, i&, x$, a, ubmax%, s, ub%, resu(), j%
Set F = Feuil1 'CodeName de la feuille, à adapter
Set dest = F.[d2] 'à adapter
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest.EntireColumn.Resize(, F.Columns.Count - dest.Column).ClearContents 'RAZ
tablo = F.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.dictionary")
For i = 2 To UBound(tablo)
    x = CStr(tablo(i, 1))
    If Not d.exists(x) Then d(x) = tablo(i, 1)
    d(x) = d(x) & " " & tablo(i, 2)
Next
If d.Count = 0 Then Exit Sub
'---restitution---
a = d.items
ubmax = -1
For i = 0 To UBound(a)
    s = Split(a(i))
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(UBound(a), ubmax)
    For j = 0 To ub
        If IsNumeric(s(j)) Then resu(i, j) = CDbl(s(j)) Else resu(i, j) = s(j)
    Next
Next
dest.Resize(d.Count, ubmax + 1) = resu
End Sub