Fusionner des cellules

Option Explicit

Sub testfusion()
Dim tableau(0 To 4), X, j&, j0&

tableau(0) = "O11"
tableau(1) = "O11"
tableau(2) = "O11"
tableau(3) = "O12"
tableau(4) = "O12"
Range(Cells(3, 1), Cells(3, UBound(tableau) + 1)).UnMerge

j0 = 0: j = j0
Do While j <= UBound(tableau)
  X = tableau(j0)
  Do While j <= UBound(tableau)
    If tableau(j) <> X Then Exit Do
    j = j + 1
  Loop
  j = j - 1
  Cells(3, j0 + 1) = X
  If j > j0 Then
    Application.DisplayAlerts = False
    Range(Cells(3, j0 + 1), Cells(3, j + 1)).Merge
    Application.DisplayAlerts = True
  End If
  Range(Cells(3, j0 + 1), Cells(3, j + 1)).HorizontalAlignment = xlCenter
  Range(Cells(3, j0 + 1), Cells(3, j + 1)).Borders.LineStyle = xlContinuous
  j0 = j + 1: j = j0
Loop
End Sub

Sub Fusionner_par_ligne()
Dim P As Range, col%, i&, j%
Set P = ActiveSheet.UsedRange
col = P.Columns.Count - 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To P.Rows.Count
  For j = col To 1 Step -1
    If P(i, j) <> "" And P(i, j) = P(i, j + 1) Then _
      P(i, j).Resize(, 2).Merge: P(i, j).HorizontalAlignment = xlCenter
  Next
Next
End Sub

Sub Fusionner_par_ligne()
Dim P As Range, t, col%, i&, j%
Set P = ActiveSheet.UsedRange
If P.Count = 1 Then Exit Sub
t = P 'matrice, plus rapide
col = UBound(t, 2) - 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To UBound(t)
  For j = col To 1 Step -1
    If t(i, j) <> "" And t(i, j) = t(i, j + 1) Then _
      P(i, j).Resize(, 2).Merge: P(i, j).HorizontalAlignment = xlCenter
  Next
Next
End Sub