Bonjour,
Essaie avec ce code en lieu et place du tien
Sub Regrouper()
'Dan
Dim Nom As Range
Dim i As Byte
Dim Val As Range
Application.ScreenUpdating = False
Sheets("Feuil1").Copy after:=Sheets(Sheets.Count)
For Each Nom In Range("A2:A" & Range("A65536").End(xlUp).Row)
For i = 1 To Range("B65536").End(xlUp).Row - 1
Set Val = Nom.Offset(i, 0)
If Val <> "" And Val = Nom Then
If Nom.Offset(0, 1) = Val.Offset(0, 1) Then
Nom.Offset(0, 2) = Nom.Offset(0, 2) & " , " & Val.Offset(0, 2)
Rows(Val.Row).Delete
i = i - 1
End If
End If
Next i
Next Nom
Application.ScreenUpdating = True
End Sub
Si ok, merci de cloturer le fil en cliquant sur le V vert à coté du bouton editer
Amicalement