Fusion Automatique sur 2 lignes

Bonjour,

J'aimerais effectuer une fusion automatique de cellules voisines contenant la même valeur et seulement si la ligne paire du dessous sera également fusionnée. Voici un exemple pour être plus clair :

Ce sujet a déjà plus ou moins été traité mais je n'arrive pas à l'adapter. J'avais jusqu'ici trouvé la méthode suivante qui ne répondait pas tout à fait à mon besoin :

Set Plage = Selection

For X = Plage.Cells.Count To 2 Step -1
    If Plage.Cells(X).Value <> "" Then
        If Plage.Cells(X).Row = Plage.Cells(X - 1).Row And _
         Plage.Cells(X) = Plage.Cells(X - 1) Then _
        Range(Plage.Cells(X - 1), Plage.Cells(X)).Merge
    End If
Next X

Bonjour Drmath4 ,

Pas simple à comprendre votre problème (je n'ai pas toujours la 'comprenette' rapide, il faut bien l'avouer)

Pour ce que j'en ai compris :

• on traite les lignes par couple de ligne (ligne 8 et ligne 7 puis ligne 6 et ligne 5, etc.).
• on commence par traiter la ligne paire du couple indépendamment de toute autre ligne.
• puis on traite la ligne (impaire) du couple en respectant les zones fusionnées de la ligne paire (c'est là que j'ai un peu de mal à comprendre si j'ai bien compris )

Dans le fichier joint, cliquer sur le bouton Hop!

Le code est dans le module de la feuille :

Sub test()
Dim der&, t, i&, j&, k&, m&

   Application.ScreenUpdating = False: Application.DisplayAlerts = False
   der = Cells(Rows.Count, "a").End(xlUp).Row
   If der Mod 2 = 1 Then MsgBox "Le nombre de ligne du tableau est impair => ECHEC !", vbCritical: Exit Sub
   Range("a1").Resize(der, 5).HorizontalAlignment = xlCenter
   t = Range("a1").Resize(der, 5)
   For i = der To 1 Step -2
      j = 1: k = j
      Do
         k = k + 1
         If k = 6 Then Exit Do
         If t(i, k) <> t(i, j) Then
            Range(Cells(i, j), Cells(i, k - 1)).Merge
            For m = j To k - 1
               If t(i - 1, m) <> t(i, j) Then Exit For
            Next m
            If m <= k - 1 Then Range(Cells(i - 1, j), Cells(i - 1, k - 1)).Merge
            j = k: k = j
         End If
      Loop
      Range(Cells(i, j), Cells(i, k - 1)).Merge
      For m = j To k - 1
         If t(i - 1, m) <> t(i, j) Then Exit For
      Next m
      If m <= k - 1 Then Range(Cells(i - 1, j), Cells(i - 1, k - 1)).Merge
   Next i
   Application.DisplayAlerts = True
End Sub

Bonjour mafraise,

Merci pour la réponse rapide. Malheureusement, je n'arrive pas tout à fait à l'adapter mais j'ai probablement très mal décrit le problème :-p

Je voulais simplifier ce problème pour être plus compréhensible mais il sera peut-être plus facile de comprendre ce que je souhaite avec le vrai fichier pour lequel j'ai besoin de cette manipulation :

En gros, dans ce fichier on voit une grille qui m'indique quel cours les élèves de 2A, 2B, ... ont et avec quel prof. Les classes sont divisées en sous-groupes et ont parfois le même cours parfois non.

Du coup, par exemple, lorsqu'il est écrit "EDM" avec "Alcazar" à la suite, il faut fusionner les lignes mais pas si c'est "LATIN3" qui se suit sans que ce soit le même prof sur la ligne du dessous (exemple avec DUPONT et LAMPION en L15-M15). D'où le fait que la fusion ne peut se faire qu'en ligne paire seulement s'il y aura aussi la même fusion en ligne impaire.

En testant le code dans l'exemple, vous verrez que ça na pas donné le résultat escompté. La feuille de base étant la feuille "2C Original".

J'espère avoir été plus clair et que vous pourrez m'aider :-) Merci en tout cas pour votre temps !

Bonjour à tous,

Un début de piste ici.

[EDIT] : hors sujet, désolé,

[EDIT2]: un essai avec une macro que j'avais en stock....je n'ai pas retrouvé le lien..

Sub FusionIdentique()
 Dim cel As Range, plage As Range
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
   With Sheets("2C Original")
    Set plage = .Range("B6:Z25")
     For Each cel In Range("B6:Z25")
      If Not Intersect(cel.Offset(, -1), plage) Is Nothing Then
       If cel = cel.Offset(, -1).MergeArea.Cells(1, 1) Then
        Range(cel, cel.Offset(, -1).MergeArea).Merge
       End If
      End If
     Next cel
   End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

CTRL + e pour exécuter la macro FusionIdentique

Cordialement,

Re,

Quel est le rapport entre le fichier que vous avez fourni dans votre 1er message et celui de votre second message ?

La présentation est totalement différente...

@mafraise

Effectivement, la présentation est très différente mais le but recherché est le même. Les fruits sont remplacés par des cours et les couleurs par des noms propres.

C'est en fait mon fichier original. Je pensais faire plus simple avec le premier fichier pour ensuite l'adapter au mien mais peut-être l'objectif cherché est plus compréhensible avec l'objectif réel.

@xorsankukai

Merci ! Le code marche pour les fusions sur même ligne sans problème mais il ne répond pas exactement à ce que je recherche car L14 et M14 fusionnent alors qu'il ne devrait pas car L15 et M15 ne sont eux pas identiques (contrairement à la double paire L22 M22 & L23 M23 qui elle doit bien être fusionnée puisque meme prof en-dessous).

Je ne sais pas si je suis clair :-s

Re,

Peut-être ainsi alors....

Sub FusionIdentiqueV2()
 Dim cel As Range, plage As Range
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
   With Sheets("2C Original")
    Set plage = .Range("B6:Z25")
     For Each cel In plage
      If Not Intersect(cel.Offset(, -1), plage) Is Nothing Then
       If cel = cel.Offset(, -1).MergeArea.Cells(1, 1) And _
          cel.Offset(1, 0) = cel.Offset(1, -1).MergeArea.Cells(1, 1) Then
         Range(cel, cel.Offset(, -1).MergeArea).Merge
         Range(cel.Offset(1, 0), cel.Offset(1, -1).MergeArea).Merge
       End If
      End If
     Next cel
   End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Cordialement,

Yes! :-D Exactement ce qu'il fallait !

Un grand merci !

Salut à tous,

A tester sur une copie de ta feuille en 1ère position dans ton classeur.

Je ne suis vraiment pas sûr de moi. ai-je bien analyser la problématique

Option Explicit
Sub fusion()
Dim r1 As Range, r2 As Range, i As Long, j As Long, lig As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        For lig = 6 To 24 Step 2
            Set r1 = .Range(.Cells(lig, 2), .Cells(lig, 25))
            Set r2 = .Range(.Cells(lig + 1, 2), .Cells(lig + 1, 25))
            For i = 1 To r1.Count
                j = 1
                Do Until r2(i) <> r2(i).Cells(, j)
                    j = j + 1
                Loop
                With .Range(r1(i), r1(i).Cells(, j - 1))
                    .Merge
                End With
                With .Range(r2(i), r2(i).Cells(, j - 1))
                    .Merge
                End With
                i = i + j - 2
            Next i
        Next lig
    End With
    Set r1 = Nothing: Set r1 = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

En fait si 2 profs ont le même nom mais pas la même matière, ça va pas le faire !!

klin89

Re drmath4,

Le code réajusté :

Option Explicit
Sub fusion()
Dim r1 As Range, r2 As Range, i As Long, j As Long, lig As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        For lig = 6 To 24 Step 2
            Set r1 = .Range(.Cells(lig, 2), .Cells(lig, 25))
            Set r2 = .Range(.Cells(lig + 1, 2), .Cells(lig + 1, 25))
            For i = 1 To r1.Count
                j = 1
                Do Until r1(i) & r2(i) <> r1(i).Cells(, j) & r2(i).Cells(, j)
                    j = j + 1
                Loop
                If j > 2 Then
                   .Range(r1(i), r1(i).Cells(, j - 1)).Merge
                   .Range(r2(i), r2(i).Cells(, j - 1)).Merge
                End If
                i = i + j - 2
            Next i
        Next lig
    End With
    Set r1 = Nothing: Set r1 = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin89,

En fait si 2 profs ont le même nom mais pas la même matière, ça va pas le faire !!

Effectivement, je n'avais pas essayé dans ce sens là. Bien vu ! Merci pour la correction du coup. En réalité, je dois encore faire en sorte de mettre une alerte dans ce cas là car ça ne peut pas arriver.

Comme je devrai faire ça sur plusieurs feuilles qui ont des tailles différentes, n'y a-t-il pas moyen de faire en sorte que l'application du code se fasse automatiquement en fonction de la taille du tableau ?

Autre chose, il y a un problème si les cellules de la dernière colonne sont déjà fusionnées (la fusion s'étend alors hors du cadre).

Merci beaucoup :-)

Re drmath4,

Je ne sais pas comment sont conçus tes tableaux, pas compris ton histoire de dernière colonne déjà fusionnée.

Sinon j'ai découvert que tu avais ajouté une liste de validation en colonne AB, supprime la et place la dans une feuille indépendante.

J'ai rajouté la variable dercol dans le code qui suit pour déterminer la dernière colonne non vide de ton tableau en m'appuyant sur la ligne 6.

Option Explicit
Sub fusion()
Dim r1 As Range, r2 As Range, i As Long, j As Long, lig As Byte, dercol As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        dercol = .Cells(6, .Columns.Count).End(xlToLeft).Column
        For lig = 6 To 24 Step 2 'on boucle de la ligne 6 à 24
            Set r1 = .Range(.Cells(lig, 2), .Cells(lig, dercol))
            Set r2 = .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol))
            'r1.Select
            For i = 1 To r1.Count
                j = 1
                Do Until r1(i) & r2(i) <> r1(i).Cells(, j) & r2(i).Cells(, j)
                    j = j + 1
                Loop
                If j > 2 Then
                   .Range(r1(i), r1(i).Cells(, j - 1)).Merge
                   .Range(r2(i), r2(i).Cells(, j - 1)).Merge
                End if
                i = i + j - 2
            Next i
        Next lig
    End With
    Set r1 = Nothing: Set r1 = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Après on peut adapter le code pour l'appliquer à un tableau structuré, demande à xorsankukai, je ne maitrise pas.

klin89

Je ne sais pas comment sont conçus tes tableaux, pas compris ton histoire de dernière colonne déjà fusionnée.

En fait, il est possible que certaines cellules soient déjà fusionnées auparavant et, à ce moment-là, si une case vide suit la ligne fusionnée, cette case vide se fusionne avec cette ligne déjà fusionnée (logique, j'imagine, puisqu'elle vaut 0, de même que la précédente). On constate par exemple ce problème si on applique la dernière macro 2 fois consécutivement. Les colonnes "blanches" utilisées pour marquer la scission entre 2 classes se fusionnent en partie.

Ces colonnes tampons sont nécessaires à une meilleures visibilité lors de l'impression. Dès lors difficile de s'en passer (sauf si j'ignore l'existence d'une possibilité de marge d'impression entre certaines colonnes).

Cela dit, je peux régler le problème en complétant ces colonnes par un caractère quelconque que je mets en blanc mais ce n'est pas très subtil :-p

Sinon j'ai découvert que tu avais ajouté une liste de validation en colonne AB, supprime la et place la dans une feuille indépendante.

Effectivement, je l'ai supprimée. Merci.

Après on peut adapter le code pour l'appliquer à un tableau structuré, demande à xorsankukai, je ne maitrise pas.

Par tableau structuré, tu entends les tableaux pour lesquels chaque colonne peut être filtrée ? Si oui, je n'ai pas l'impression qu'il soit adéquat à la mise en page que j'aimerais garder (facilité de lecture à l'impression).

Dernière version fichier :

J'ai résolu le problème en ajoutant la ligne If Not r1(i)=0 Then :-)

Sub fusion()
Dim r1 As Range, r2 As Range, i As Long, j As Long, lig As Byte, dercol As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        dercol = .Cells(6, .Columns.Count).End(xlToLeft).Column
        For lig = 6 To 24 Step 2 'on boucle de la ligne 6 à 24
            Set r1 = .Range(.Cells(lig, 2), .Cells(lig, dercol))
            Set r2 = .Range(.Cells(lig + 1, 2), .Cells(lig + 1, dercol))
            'r1.Select
            For i = 1 To r1.Count
                j = 1
                If Not r1(i) = 0 Then
                Do Until r1(i) & r2(i) <> r1(i).Cells(, j) & r2(i).Cells(, j)
                    j = j + 1
                Loop
                .Range(r1(i), r1(i).Cells(, j - 1)).Merge
                .Range(r2(i), r2(i).Cells(, j - 1)).Merge

                i = i + j - 2
                End If
            Next i
        Next lig
    End With
    Set r1 = Nothing: Set r1 = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

J'ai bien l'impression que maintenant, tout roule comme espéré :-) Merci à tous !

Vous dites :

Cela dit, je peux régler le problème en complétant ces colonnes par un caractère quelconque que je mets en blanc mais ce n'est pas très subtil

Apres test, 'est sûrement la meilleure des solutions finalement.

Sinon, il faut parcourir les zones une à une, et je n'ai pas envie de monter une usine à gaz.

klin89