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