Fusion de cellule automatique

Bonjour,

Pour une question de mise en forme, je cherche à automatiser la fusion de cellules dans une colonne.

dans la première colonne, une liste fait état de différentes valeurs, ces valeurs varient en quantité et répétition

je souhaite mettre en place une macro qui me permette de fusionner les cellules qui ont la même valeur

dans la colonne E, on peut voir un exemple de résultat souhaité.

le Bouton 1 permet de lancer une macro qui fonctionne mais est un peu lourde et elle est limité.

elle ne peut fusionner que 6 cellules maximum.

De plus, à chaque fusion, il faut valider en cliquant sur OK. Ce n'est pas très pratique si on doit valider une cinquantaine de fois.

Sub fusion() 'en cours de creation
'fusionne les etapes entre elles par 6

Dim i As Integer
Dim n As Integer

n = 1 'la première ligne moins un

For i = 1 To 50

If Cells(n + i, 1) = Cells(n + 1 + i, 1) And Cells(n + i, 1) = Cells(n + 2 + i, 1) And Cells(n + i, 1) = Cells(n + 3 + i, 1) And Cells(n + i, 1) = Cells(n + 4 + i, 1) And Cells(n + i, 1) = Cells(n + 5 + i, 1) And Cells(n + i, 1) = Cells(n + 6 + i, 1) Then
    Range(Cells(n + i, 1), Cells(n + 6 + i, 1)).Activate
    Selection.Merge

ElseIf Cells(n + i, 1) = Cells(n + 1 + i, 1) And Cells(n + i, 1) = Cells(n + 2 + i, 1) And Cells(n + i, 1) = Cells(n + 3 + i, 1) And Cells(n + i, 1) = Cells(n + 4 + i, 1) And Cells(n + i, 1) = Cells(n + 5 + i, 1) Then
    Range(Cells(n + i, 1), Cells(n + 5 + i, 1)).Activate
    Selection.Merge

ElseIf Cells(n + i, 1) = Cells(n + 1 + i, 1) And Cells(n + i, 1) = Cells(n + 2 + i, 1) And Cells(n + i, 1) = Cells(n + 3 + i, 1) And Cells(n + i, 1) = Cells(n + 4 + i, 1) Then
    Range(Cells(n + i, 1), Cells(n + 4 + i, 1)).Activate
    Selection.Merge

ElseIf Cells(n + i, 1) = Cells(n + 1 + i, 1) And Cells(n + i, 1) = Cells(n + 2 + i, 1) And Cells(n + i, 1) = Cells(n + 3 + i, 1) Then
    Range(Cells(n + i, 1), Cells(n + 3 + i, 1)).Activate
    Selection.Merge

ElseIf Cells(n + i, 1) = Cells(n + 1 + i, 1) And Cells(n + i, 1) = Cells(n + 2 + i, 1) Then
    Range(Cells(n + i, 1), Cells(n + 2 + i, 1)).Activate
    Selection.Merge

ElseIf Cells(n + i, 1) = Cells(n + 1 + i, 1) Then
Range(Cells(n + i, 1), Cells(n + 1 + i, 1)).Activate
    With Selection 'mise en page de la selection, partie facultative
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End If

Next i
End Sub

astuce : le bouton état initial ne sert qu'à remettre la colonne à l'état initial pour tester facilement sa macro.

Si jamais vous avez une idée?

Bonjour,

Je déconseille fortement de fusionner. Par contre on peut alléger la présentation des valeurs récurrentes par le biais d'une MFC, donc sans macro.

https://www.excel-pratique.com/fr/telechargements/doc-excel/fusionner-mfc-excel-no474

Je déconseille également de fusionner. Dès que tu veux trier, filtrer, faire des formules, tout devient plus complexe.

Si c'est pour une mise en page, applique plutôt un remplissage de cellule sans bordure, tu auras similairement le même résultat.

Bonne soirée !

Steelson a écrit :

Je déconseille fortement de fusionner. Par contre on peut alléger la présentation des valeurs récurrentes par le biais d'une MFC, donc sans macro.

Je me doutais qu'on allait me répondre ça.

Effectivement fusionner des cellules pose de nombreux problèmes par la suite pour exploiter des données.

Mais comme je le disait dans le post précédent, ce n'est que dans un but de mise en forme pour impression, ce document papier servira de base pour recueillir des données écrites au stylos.

Je trouve ton idée de passer par une MFC très maligne. Mais cette solution ne correspond pas tout à fait à mes attentes. Ce genre de méthode pourra surement me servir dans d'autres cas, mais pas ici.

Merci quand même.

Bonsoir,

Un test rapide et pas très esthétique.

Sub fusion()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
r = 2
LAST_ROW = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To LAST_ROW
        If .Cells(r, 1) = .Cells(i, 1) Then
        .Range(.Cells(r, 1), .Cells(i, 1)).Select
        Else
        Selection.Merge
        r = i
        End If
    Next i
Selection.Merge
.Range("A1:A" & LAST_ROW).HorizontalAlignment = xlHAlignCenter
.Range("A1:A" & LAST_ROW).VerticalAlignment = xlVAlignCenter
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Bonne soirée,

Donc si je comprends bien ;

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ça, ça sert à désactiver la validation à chaque fusion, et tu le ré-active ensuite

Sub fusion()
r = 2
LAST_ROW = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To LAST_ROW
        If .Cells(r, 1) = .Cells(i, 1) Then
        .Range(.Cells(r, 1), .Cells(i, 1)).Select
        Else
        Selection.Merge
        r = i
        End If
    Next i

Et ça c'est la boucle qui sélectionne les cellules consécutives qui ont la même valeurs entre elles.

Ben parfait ça marche nickel

reste plus qu'à l'adapter dans mon fichier originel

Bon boulot, MERCI

Bonjour,

C'est exactement ça.

'Désactivation de la mise à jour à l'écran
Application.ScreenUpdating = False
'Désactivation des popups
Application.DisplayAlerts = False

La boucle compare à chaque fois la cellule et la cellule d'en dessous. Si c'est le cas alors elle selectionne les cellules et ainsi de suite. Dans le cas contraire elle fusionne les cellules (donc la selection des cellules de même valeurs vu précédemment) et recommence un nouveau cycle à partir de la ligne en cours (d'où r=i et ensuite on tape sur r et i qui devient dans la boucle suivante i+1).

Je ne suis pas fan du tout des select mais ça fait l'affaire pour une utilisation occasionnelle sur peu de données.

Bon dimanche.

Voici la version sans VBA commentée.