XL 2016 Fusion cellule VBA

Ethlios · 13 Avril 2022

Bonjour à tous,

Je cherche un code VBA permettant fusionner des cellules. Exemple, je définis un nombre de cellule en amont, 20 cellules, et je veux en fusionner 2, puis 5, puis 7... à la suite, sans pour autant fusionner les 20. J'imaginais donc un système d'inputbox qui pose plusieurs fois la même question jusqu'à écrire 0 pour arrêter le code. Comment retranscrire cela en code VBA.

Exemple en pièce jointe pour illustré

Merci d'avance pour votre aide.

Ethlios

Dudu2 · 13 Avril 2022

Bonjour,

je définis un nombre de cellule en amont, 20 cellules

Tu les définis comment en amont ?

Voici un code qui fait ça sur la base d'un sélection préalable de cellules contigües (pas d'Areas multiples).
Il faut lancer la Macro soit par un bouton, soit par un raccourci clavier après la sélection.
La fusion se fait par lignes.

VB:

Sub FusionCellules()
    Dim RangeRestant As Range
    Dim Réponse As Variant
    Dim NbV As Integer

    If Not TypeOf Selection Is Range Then Exit Sub
    If Selection.Areas.Count > 1 Then Exit Sub
    If Selection.Cells.Count = 1 Then Exit Sub
   
    Set RangeRestant = Selection
   
    Do While Not RangeRestant Is Nothing
        Réponse = Application.InputBox("Combien de cellules sont à fusionner en hauteur ?", "Fusion", "2", Type:=1)
        If VarType(Réponse) = vbBoolean Then Exit Sub
       
        NbV = CInt(Réponse)
        If NbV = 0 Or NbV > RangeRestant.Rows.Count Then
            MsgBox "Le nombre de cellules à fusionner dépasse les limites du range restant à fusionner"
        Else
            If RangeRestant.Cells(1, 1).Resize(NbV, RangeRestant.Columns.Count).Cells.Count = 1 Then
                MsgBox "Il faut au moins 2 cellules pour une fusion"
            Else
                RangeRestant.Cells(1, 1).Resize(NbV, RangeRestant.Columns.Count).MergeCells = True
                If RangeRestant.Rows.Count = NbV Then
                    Set RangeRestant = Nothing
                Else
                    Set RangeRestant = RangeRestant.Cells(NbV + 1, 1).Resize(RangeRestant.Rows.Count - NbV, RangeRestant.Columns.Count)
                    If RangeRestant.Cells.Count = 1 Then
                        Set RangeRestant = Nothing
                    Else
                        MsgBox "Encore " & RangeRestant.Rows.Count & " lignes à fusionner."
                    End If
                End If
            End If
        End If
    Loop
   
    MsgBox "Fusion terminée."
End Sub

job75 · 13 Avril 2022

Bonsoir Ethkios, Dudu2,

Voyez le fichier joint et la macro affectée au bouton :

VB:

Sub Fusion()
Dim r As Range
On Error Resume Next
Set r = Application.InputBox("Sélectionnez les cellules jaunes à fusionner :", Type:=8)
If r Is Nothing Then Exit Sub
Set r = Intersect(r, [G4:X4])
If Not r Is Nothing Then r.Merge: r.Select
End Sub

Bonne nuit.

Ethlios · 14 Avril 2022

Dudu2 à dit:

Bonjour,

Tu les définis comment en amont ?

Voici un code qui fait ça sur la base d'un sélection préalable de cellules contigües (pas d'Areas multiples).
Il faut lancer la Macro soit par un bouton, soit par un raccourci clavier après la sélection.
La fusion se fait par lignes.

VB:

Sub FusionCellules()
    Dim RangeRestant As Range
    Dim Réponse As Variant
    Dim NbV As Integer

    If Not TypeOf Selection Is Range Then Exit Sub
    If Selection.Areas.Count > 1 Then Exit Sub
    If Selection.Cells.Count = 1 Then Exit Sub
 
    Set RangeRestant = Selection
 
    Do While Not RangeRestant Is Nothing
        Réponse = Application.InputBox("Combien de cellules sont à fusionner en hauteur ?", "Fusion", "2", Type:=1)
        If VarType(Réponse) = vbBoolean Then Exit Sub
     
        NbV = CInt(Réponse)
        If NbV = 0 Or NbV > RangeRestant.Rows.Count Then
            MsgBox "Le nombre de cellules à fusionner dépasse les limites du range restant à fusionner"
        Else
            If RangeRestant.Cells(1, 1).Resize(NbV, RangeRestant.Columns.Count).Cells.Count = 1 Then
                MsgBox "Il faut au moins 2 cellules pour une fusion"
            Else
                RangeRestant.Cells(1, 1).Resize(NbV, RangeRestant.Columns.Count).MergeCells = True
                If RangeRestant.Rows.Count = NbV Then
                    Set RangeRestant = Nothing
                Else
                    Set RangeRestant = RangeRestant.Cells(NbV + 1, 1).Resize(RangeRestant.Rows.Count - NbV, RangeRestant.Columns.Count)
                    If RangeRestant.Cells.Count = 1 Then
                        Set RangeRestant = Nothing
                    Else
                        MsgBox "Encore " & RangeRestant.Rows.Count & " lignes à fusionner."
                    End If
                End If
            End If
        End If
    Loop
 
    MsgBox "Fusion terminée."
End Sub

Je les définis par la taille de mon tableau.

NB:
*Quand je sélectionne les cellules et que je lance la macro puis j'inscris le nombre de cellules à fusionner cela ne fonctionne pas j'ai le message "Le nombre de cellules à fusionner dépasse les limites du range restant à fusionner" la seule valeur qui fonctionne est 1

job75 · 14 Avril 2022

Bonjour,

Testez svp le fichier de mon post #3.

A+

Dudu2 · 14 Avril 2022

*Quand je sélectionne les cellules et que je lance la macro puis j'inscris le nombre de cellules à fusionner cela ne fonctionne pas j'ai le message "Le nombre de cellules à fusionner dépasse les limites du range restant à fusionner" la seule valeur qui fonctionne est 1

C'est que n'as sélectionné qu'une seule ligne. Donc 1 pour 1 ligne.
Les cellules de la ligne sélectionnée seront fusionnées.

Dudu2 · 14 Avril 2022

A moins que tu veuilles fusionner des groupes de cellules sur 1 seule ligne.
Dans ce cas il faut le préciser. Car j'ai codé pour fusionner des cellules sur plusieurs lignes.

Ethlios · 14 Avril 2022

Dudu2 à dit:
A moins que tu veuilles fusionner des groupes de cellules sur 1 seule ligne.
Dans ce cas il faut le préciser. Car j'ai codé pour fusionner des cellules sur plusieurs lignes.

Oui, c'est ce que je cherche, fusionné des cellules sur une seul ligne, ou faut-il le préciser dans le code ?

Ethlios · 14 Avril 2022

job75 à dit:
Bonjour,

Testez svp le fichier de mon post #3.

A+

Bonjour,

Votre fonction marche bien, mais je cherche une formule comme celle de Dudu2

Merci tout de même pour votre l'aide !

Dudu2 · 14 Avril 2022

Bon, dans cette version j'ai intégré la fusion de lignes et la fusion de colonnes (prompt au début).
Tu devrais choisir l'option fusion en colonnes valable pour 1 ou plusieurs lignes.
L'option fusion en lignes est elle valable pour 1 ou plusieurs colonnes.

Ça gère aussi l'erreur qui intervient lorsqu'on annule un fusion suite au warning Excel des valeurs qui ne sont pas reportées.

VB:

Sub FusionCellules()
    Dim RangeRestant As Range
    Dim Réponse As Variant
    Dim Nb As Integer
    Dim FusionLignes As Boolean
    Dim ErrNumber As Long
  
    If Not TypeOf Selection Is Range Then Exit Sub
    If Selection.Areas.Count > 1 Then Exit Sub
    If Selection.Cells.Count = 1 Then Exit Sub
 
    Set RangeRestant = Selection
  
    Do While 1
        Réponse = Application.InputBox("Fusionner des cellules en lignes (L) ou en colonnes (C) ?", "Fusion", "C", Type:=2)
        If VarType(Réponse) = vbBoolean Then Exit Sub
      
        Select Case UCase(Réponse)
            Case "C"
                FusionLignes = False
                Exit Do
            Case "L"
                FusionLignes = True
                Exit Do
            Case Else
                MsgBox "Répondre 'L' pour fusion de lignes ou 'C' pour fusion de colonnes."
        End Select
    Loop
 
    Do While Not RangeRestant Is Nothing
        'Fusion de lignes
         If FusionLignes Then
             Réponse = Application.InputBox("Combien de lignes sont à fusionner ?", "Fusion", RangeRestant.Rows.Count, Type:=1)
             If VarType(Réponse) = vbBoolean Then Exit Sub
          
             Nb = CInt(Réponse)
      
            If Nb = 0 Or Nb > RangeRestant.Rows.Count Then
                MsgBox "Le nombre de lignes à fusionner dépasse les limites du range restant"
            Else
                If RangeRestant.Cells(1, 1).Resize(Nb, RangeRestant.Columns.Count).Cells.Count = 1 Then
                    MsgBox "Il faut au moins 2 cellules pour une fusion"
                Else
                    On Error Resume Next
                    RangeRestant.Cells(1, 1).Resize(Nb, RangeRestant.Columns.Count).MergeCells = True
                    ErrNumber = Err.Number
                    On Error GoTo 0
                  
                    If ErrNumber = 0 Then
                        If RangeRestant.Rows.Count = Nb Then
                            Set RangeRestant = Nothing
                        Else
                            Set RangeRestant = RangeRestant.Cells(Nb + 1, 1).Resize(RangeRestant.Rows.Count - Nb, RangeRestant.Columns.Count)
                            If RangeRestant.Cells.Count = 1 Then
                                Set RangeRestant = Nothing
                            Else
                                MsgBox "Encore " & RangeRestant.Rows.Count & " lignes à fusionner"
                            End If
                        End If
                    End If
                End If
            End If
      
        'Fusion de colonnes
        Else
            Réponse = Application.InputBox("Combien de colonnes sont à fusionner ?", "Fusion", RangeRestant.Columns.Count, Type:=1)
            If VarType(Réponse) = vbBoolean Then Exit Sub
          
             Nb = CInt(Réponse)
          
            If Nb = 0 Or Nb > RangeRestant.Columns.Count Then
                MsgBox "Le nombre de colonnes à fusionner dépasse les limites du range restant"
            Else
                If RangeRestant.Cells(1, 1).Resize(RangeRestant.Rows.Count, Nb).Cells.Count = 1 Then
                    MsgBox "Il faut au moins 2 cellules pour une fusion"
                Else
                    On Error Resume Next
                    RangeRestant.Cells(1, 1).Resize(RangeRestant.Rows.Count, Nb).MergeCells = True
                    ErrNumber = Err.Number
                    On Error GoTo 0
                  
                    If ErrNumber = 0 Then
                        If RangeRestant.Columns.Count = Nb Then
                            Set RangeRestant = Nothing
                        Else
                            Set RangeRestant = RangeRestant.Cells(1, Nb + 1).Resize(RangeRestant.Rows.Count, RangeRestant.Columns.Count - Nb)
                            If RangeRestant.Cells.Count = 1 Then
                                Set RangeRestant = Nothing
                            Else
                                MsgBox "Encore " & RangeRestant.Columns.Count & " colonnes à fusionner"
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Loop
 
    MsgBox "Fusion terminée."
End Sub

Ethlios · 14 Avril 2022

Franchement, c'est im-pe-cca-ble, encore merci infiniment pour l'aide, la macro est parfaite !!

job75 · 14 Avril 2022

C'est vrai que mon fichier (1) ne faisait pas exactement ce qui était demandé, alors voyez ce fichier (2).

On traite uniquement la plage G4:X4, comme indiquée dans le fichier du post #1 :

VB:

Sub Fusion()
Dim R As Range, ncol%, x, n, nn%
Set R = [G4:X4] 'vecteur ligne à adapter
ncol = R.Count
R.UnMerge 'RAZ
R(1).Copy R
Do
    x = Application.InputBox("Nombre de cellules à fusionner :", "Fusion", IIf(n > 0, "", CStr(x)), 2)
    If VarType(x) = vbBoolean Then Exit Sub
    n = Int(Val(x))
    If n > 0 Then
        If nn + n > ncol Then n = ncol - nn
        With R(1, nn + 1).Resize(, n)
            .Merge
            .Select
            If nn + n >= ncol - 1 Then MsgBox "Terminée", , "Fusion": Exit Sub
            nn = nn + n
        End With
    End If
Loop
End Sub

Ethlios · 14 Avril 2022

job75 à dit:

C'est vrai que mon fichier (1) ne faisait pas exactement ce qui était demandé, alors voyez ce fichier (2).

On traite uniquement la plage G4:X4, comme indiquée dans le fichier du post #1 :

VB:

Sub Fusion()
Dim R As Range, ncol%, x, n, nn%
Set R = [G4:X4] 'vecteur ligne à adapter
ncol = R.Count
R.UnMerge 'RAZ
R(1).Copy R
Do
    x = Application.InputBox("Nombre de cellules à fusionner :", "Fusion", IIf(n > 0, "", CStr(x)), 2)
    If VarType(x) = vbBoolean Then Exit Sub
    n = Int(Val(x))
    If n > 0 Then
        If nn + n > ncol Then n = ncol - nn
        With R(1, nn + 1).Resize(, n)
            .Merge
            .Select
            If nn + n >= ncol - 1 Then MsgBox "Terminée", , "Fusion": Exit Sub
            nn = nn + n
        End With
    End If
Loop
End Sub

C'est encore mieux ! Merci beaucoup !!

Effectuez une recherche sur Excel Downloads...

XL 2016 Fusion cellule VBA

Ethlios

XLDnaute Junior

Pièces jointes

Dudu2

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Ethlios

XLDnaute Junior

job75

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Ethlios

XLDnaute Junior

Ethlios

XLDnaute Junior

Dudu2

XLDnaute Barbatruc

Ethlios

XLDnaute Junior

job75

XLDnaute Barbatruc

Pièces jointes

Ethlios

XLDnaute Junior

Discussions similaires

Nous accordons de l'importance à votre vie privée