Script de fusion de cellules identiques sur une colonne

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

arthurho

XLDnaute Junior
Bonjour,

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

Code:
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.
 

Pièces jointes

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

Code:
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,
 
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() ?

Code:
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
 
Re : Script de fusion de cellules identiques sur une colonne

Re

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

Code:
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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
518
Réponses
40
Affichages
2 K
Retour