Fusionner des cellules

[awa123]

Bonjour,

j'aimerais fusionner les cellules identiques qui sont consécutives

voici le petit code sur lequel je fais mes test

    Sub test()
     
     

    Dim tableau(5) As Variant
     
     
    tableau(0) = "O11"
    tableau(1) = "O11"
    tableau(2) = "O11"
    tableau(3) = "O12"
    tableau(4) = "O12"

    For i = 0 To UBound(tableau)
     
     
     If tableau(i) <> "" Then
     
        Cells(3, 1 + i) = tableau(i)
     End If
     
    Next i

     
      End Sub

je vous joins mon fichier qui illustre ce que j'aimerais avoir


merci beaucoup

 

[mapomme]

Re : Fusionner des cellules

Bonjour awa123,

Un essai dans le fichier joint avec pour code:

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

 

[job75]

Re : Fusionner des cellules

Bonjour awa123, salut mapomme

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

Fichier joint.

A+

 

[job75]

Re : Fusionner des cellules

Re,

S'il y a beaucoup de cellules à étudier ceci sera plus rapide :

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

Fichier (2).

A+