Sub Regrouper()
Dim plage As Range, ncol%, d As Object, i&, ii&, t1$, j%, t2$, k&
Set plage = Sheets("Données").Range("A1", Sheets("Données").UsedRange)
If plage.Rows.Count = 1 Then Exit Sub 'sécurité
ncol = plage.Columns.Count
plage.Sort plage(1), xlAscending, Header:=xlYes 'tri avec titres
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
If plage(i, 1) <> "" Then
If Not d.exists(plage(i, 1).Value2) Then
ii = i + Application.CountIf(plage.Columns(1), plage(i, 1)) - 1
t1 = ""
For j = 2 To ncol
t2 = ""
For k = i To ii
If plage(k, j) <> "" Then t2 = plage(k, j): Exit For
Next
t1 = t1 & Chr(1) & t2
Next
d(plage(i, 1).Value2) = plage(i, 1).Value2 & t1
End If
End If
Next
'---restitution---
With Sheets("Résultats")
.Cells.ClearContents
.[A1].Resize(d.Count) = Application.Transpose(d.items)
Application.DisplayAlerts = False
.[A:A].TextToColumns .[A1], xlDelimited, Other:=True, OtherChar:=Chr(1)
.Activate
End With
End Sub