Sub fusionB()
' fusionner cellules identiques en B
Dim datas, lig As Long, nb As Long
datas = [B1].Resize(Cells(Rows.Count, 2).End(xlUp).Row + 1).Value
Application.DisplayAlerts = False
Application.ScreenUpdating = False
nb = 1
For lig = 2 To UBound(datas)
If datas(lig, 1) = datas(lig - 1, 1) Then
If datas(lig, 1) <> "" Then nb = nb + 1
ElseIf nb > 1 Then
Cells(lig, 2).Offset(-nb).Resize(nb).Merge: nb = 1
End If
Next lig
Application.DisplayAlerts = True
End Sub