Sub RegroupeUniquesCode() ' si doublons dans les indices
Set f = Sheets("feuil1")
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Tbl = f.Range("A2:B" & f.[a65000].End(xlUp).Row).Value
For i = LBound(Tbl) To UBound(Tbl) ' élimination doublons pour un code
If Tbl(i, 2) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""
Next i
For Each c In d1.keys ' regroupement par code
a = Split(c, "|")
d(a(0)) = d(a(0)) & a(1) & "|"
Next c
Set f2 = Sheets("feuil2")
n = d.Count
Dim TblRes: ReDim TblRes(1 To d.Count, 1 To 2)
i = 0
For Each c In d.keys
i = i + 1
TblRes(i, 1) = c: TblRes(i, 2) = d(c)
Next c
f2.[A2].Resize(d.Count, 2) = TblRes
Application.DisplayAlerts = False
f2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
f2.Cells.EntireRow.AutoFit
End Sub