Sub FusionIdentique()
Dim cel As Range
Application.DisplayAlerts = False
For Each cel In Selection
If cel.Column > 1 Then
If Not Intersect(cel.Offset(, -1), Selection) Is Nothing Then
If cel = cel.Offset(, -1).MergeArea.Cells(1, 1) Then _
Range(cel, cel.Offset(, -1).MergeArea).Merge
End If
End If
Next
End Sub