XL 2016 Fusion cellule VBA

E

Ethlios

XLDnaute Junior
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
 

Pièces jointes

  • Fusion cellule exemple.xlsm
    27.9 KB · Affichages: 8
Trier par date Trier par votes
Dudu2

Dudu2

XLDnaute Barbatruc
Bonjour,
je définis un nombre de cellule en amont, 20 cellules
Cliquez pour agrandir...
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
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Fusion cellule exemple(1).xlsm
    32 KB · Affichages: 4
Vote positif 0 Vote négatif
E

Ethlios

XLDnaute Junior
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
Cliquez pour agrandir...

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
 
Dernière édition:
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
*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
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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
 

Pièces jointes

  • Fusion cellule exemple(2).xlsm
    33.5 KB · Affichages: 0
Dernière édition:
Vote positif 0 Vote négatif
E

Ethlios

XLDnaute Junior
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
Cliquez pour agrandir...
C'est encore mieux ! Merci beaucoup !!
 
Vote positif 0 Vote négatif

Discussions similaires

W
  • Question
Microsoft 365 Fusionne les cellules vides parmi celle avec des valeurs
Réponses
4
Affichages
192
woira95
W
A
  • Question
XL 2016 Fusion cellules via VBA
Réponses
3
Affichages
432
fanfan38
fanfan38
halecs93
  • Résolu(e)
XL 2016 récupérer textbox dans une cellule fusionnée
Réponses
3
Affichages
340
laurent950
laurent950
E
  • Question
Microsoft 365 utilisation de la fonction rechercher/remplacer pour ajouter un caractère d'annihilation par ' en amont de chaque contenu de la cellule
Réponses
2
Affichages
103
elgringo123456
E
A
  • Résolu(e)
Microsoft 365 VBA - Tri par couleur de cellule
2
Réponses
16
Affichages
262
AD95
A
S
  • Question
XL 2021 ecrire macro vba
Réponses
2
Affichages
164
Bernard_XLD
Bernard_XLD
S
  • Question
XL 2019 Fusionner automatiquement des cellules suivant valeur d autre cellule + faire une calcul
Réponses
8
Affichages
427
snoopy07
S
C
  • Résolu(e)
XL 2021 vba fusion lignes et colonnes pour cellules identiques
2
Réponses
24
Affichages
1 K
cbar
C
F
  • Résolu(e)
Microsoft 365 Effacer le contenu si cellule suivante identique
Réponses
8
Affichages
128
fanch55
fanch55
F
  • Question
XL 2016 VBA : insérer dans cellule, un script de formule recréé sous VBA
Réponses
2
Affichages
156
F22Raptor
F

Membres actuellement en ligne

22 membres et 257 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 082
Messages
2 085 167
Membres
102 801
dernier inscrit
mrclbl