Sub Fusionner()
Dim i&, P As Range, resu As Range
Application.ScreenUpdating = False
On Error Resume Next 'sécurité
With [A1].CurrentRegion
.Columns(4).Resize(, Columns.Count - 3).Delete xlToLeft 'RAZ
.Columns(4).Resize(, Columns.Count - 3).HorizontalAlignment = xlCenter 'centrage
For i = 2 To .Rows.Count
.Cells(i, .Cells(i, 2)).Resize(, .Cells(i, 3)).Merge 'fusion
.Cells(i, .Cells(i, 2)) = .Cells(i, 1)
Set P = .Cells(1, .Cells(i, 2)).Resize(, .Cells(i, 3)) 'en ligne 1
Set resu = .Range(IIf(resu Is Nothing, P, resu), P)
Next
End With
resu.Merge 'fusion en ligne 1
resu = "Résultat"
End Sub