Script de fusion de cellules identiques sur une colonne

[arthurho]

Bonjour,

J'ai réalisé la macro suivante qui marche presque ..

Sub FusionneCelluleIdentique()

Application.ScreenUpdating = False
Dim lastcell As String
Dim tableau() As String, tableauligne() As String
Dim i As Integer
i = 1
lastcell = False
    With Sheets("Feuil2").Range("H4:H60000").Select
       
        activecell.Interior.ColorIndex = -4142
          Do While Not (IsEmpty(activecell))
                If lastcell <> activecell.Value Then
                    ReDim Preserve tableau(1 To i)
                    ReDim Preserve tableauligne(1 To i)
                    tableau(i) = activecell.Value
                    tableauligne(i) = activecell.Row
                    i = i + 1
                End If
                      lastcell = activecell.Value
      activecell.Offset(1, 0).Select
    Loop
        End With
        For i = 1 To UBound(tableauligne)
        
        With Sheets("Feuil2").Range("H" & tableauligne(i) & ":H" & tableauligne(i + 1))
        'Cells(1, tableauligne(i)), Cells(1, tableauligne(i + 1))).Select
              .Merge
              .HorizontalAlignment = xlHAlignCenter
              .Value = tableau(i)
              .Font.Bold = True
        End With
        i = i + 1
        Next i



        
End Sub

Le probleme est que je ne sais pas la ligne de la dernière cellule non vide de la colonne H, ca me permettrait de définir la range de la deuxieme fusion.
Mon objectif est de convertir une colonne du type :
---------------A <-- Début 1ère fusion (tableauligne(1))
---------------A
---------------A
---------------A <-- Fin 1ere fusion (tableauligne(2))
---------------B <-- Début 2eme fusion (tableauligne(3))
---------------B
---------------B <-- fin 2eme fusion (tableauligne(4))
en
---------------
---------------
---------------A (fusion des 4 cellules de la colonne H)
---------------
---------------
---------------B (fusion des 3 cellules de la colonne H)
---------------

Avez vous une solution ?

Ci joint le fichier excel utilisé (code dans module)

Merci de votre aide,

Cdt,
Arthur HO.

 

[arthurho]

Re : Script de fusion de cellules identiques sur une colonne

J'ai également un message d'avertissement, je dois cliquer OK ,
savez vous comment m'en débarrasser ?

 

[pierrejean]

Re : Script de fusion de cellules identiques sur une colonne

Bonsoir arthurho

Vois si cela te convient

 

[arthurho]

Re : Script de fusion de cellules identiques sur une colonne

Merci de ton aide, ton code est plus clair car plus simple.

donc pour faire disparaitre le message dalerte, cest bien application.displayalerts = false

Merci encore une fois,

Bonne journée

 

[arthurho]

Re : Script de fusion de cellules identiques sur une colonne

Rebonjour,

Jessaye d'executer ce code à partir d'une autre sheet. Je suis en train de m'emmeler avec la syntaxe pour la selection de la feuille désirée (feuille2) et pour éxecuter ton code, a partir de feuil1 par exemple , j'ai complété ton code de cette manière

Sub FusionneCelluleIdentique()

Application.ScreenUpdating = False
Dim lastcell As String
Dim tableau() As String, tableauligne() As String
Dim i As Integer
i = 1
lastcell = False
    With Sheets("Feuil2").Range("A1:A65536")
    .Select
    ldst = Sheets("Feuil2").Range("A65536").End(xlUp).Row
    Dim tablo
    ReDim tablo(0)
    Debut = 1
    For n = 1 To ldst
      If Sheets("Feuil2").Range("A" & n + 1) <> Sheets("Feuil2").Range("A" & n) Then
       fin = n
       tablo(UBound(tablo)) = "A" & Debut & ":" & "A" & fin
       ReDim Preserve tablo(UBound(tablo) + 1)
       Debut = n + 1
      End If
    Next n
    Application.DisplayAlerts = False
    For n = LBound(tablo) To UBound(tablo) - 1
      Range(tablo(n)).MergeCells = True
      Range(tablo(n)).HorizontalAlignment = xlHAlignCenter
      Range(tablo(n)).Font.Bold = True
    Next n
    Application.DisplayAlerts = True
    
           
       
       
End With

Pourquoi ceci ne marche pas ?
Erreur au niveau du .select
Je te remercie,

cordialement,

 

[arthurho]

Re : Script de fusion de cellules identiques sur une colonne

Il y a surement un truc que je n'ai pas compris avec les with , ce code marche comme je le souhaite, mais pourquoi ne faut il pas indiquer la feuille pour les Range() ?

Sub FusionneCelluleIdentique()

Application.ScreenUpdating = False
Dim lastcell As String
Dim tableau() As String, tableauligne() As String
Dim i As Integer
i = 1
lastcell = False
    With Sheets("Feuil2").Select
    Range("A1:A65536").Select
    ldst = Range("A65536").End(xlUp).Row
    Dim tablo
    ReDim tablo(0)
    Debut = 1
    
    For n = 1 To ldst
      If Range("A" & n + 1) <> Range("A" & n) Then
       fin = n
       tablo(UBound(tablo)) = "A" & Debut & ":" & "A" & fin
       ReDim Preserve tablo(UBound(tablo) + 1)
       Debut = n + 1
      End If
    Next n
    Application.DisplayAlerts = False
    For n = LBound(tablo) To UBound(tablo) - 1
      Range(tablo(n)).MergeCells = True
      Range(tablo(n)).HorizontalAlignment = xlHAlignCenter
      Range(tablo(n)).Font.Bold = True
    Next n
    Application.DisplayAlerts = True
    
           
       
       
End With


        
End Sub

 

[pierrejean]

Re : Script de fusion de cellules identiques sur une colonne

Re

Ta macro corrigée dans le cadre du fichier #3

Sub FusionneCelluleIdentique()
Application.ScreenUpdating = False
Dim lastcell As String
Dim tableau() As String, tableauligne() As String
Dim i As Integer
i = 1
lastcell = False
    With Sheets("Feuil2")
    'With Sheets("Feuil2").Range("A1:A65536")
    '.Select
    ldst = Sheets("Feuil2").Range("H65536").End(xlUp).Row
    Dim tablo
    ReDim tablo(0)
    Debut = 1
    For n = 1 To ldst
      If Sheets("Feuil2").Range("H" & n + 1) <> Sheets("Feuil2").Range("H" & n) Then
       fin = n
       tablo(UBound(tablo)) = "H" & Debut & ":" & "H" & fin
       ReDim Preserve tablo(UBound(tablo) + 1)
       Debut = n + 1
      End If
    Next n
    Application.DisplayAlerts = False
    For n = LBound(tablo) To UBound(tablo) - 1
      .Range(tablo(n)).MergeCells = True
      .Range(tablo(n)).HorizontalAlignment = xlHAlignCenter
      .Range(tablo(n)).Font.Bold = True
    Next n
    Application.DisplayAlerts = True
End With
End Sub