VBA: conditions des cellules fusionner

  • Initiateur de la discussion Initiateur de la discussion Anr1
  • Date de début Date de début

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 !

Anr1

XLDnaute Occasionnel
Bonjour Forum,

J'ai besoin de vos aides , j'ai un tableau avec des des cellules de colonne "B" fusionner : des fois deux cellules et des fois plus

Sur ce, J'aimerais bien avoir un programme VBA qui permets de rendre les cellules fusionner en une seul cellules ( comme le cas des doublons) avec condition :

- Les valeurs de colonne "G" et "H" séparer pas ";"
-Additionner les valeurs de colonne " I" jusqu'à "M"

Ci-joint le fichier avec :

-Feuil1 = mon tableau
-Feuil2 = solution

Ma base de données est bcp plus grand que celle de mon fichier joint
NB : @mapomme à déjà créer un programme VBA qui respecte les même condition mais dans le cas des doublons


Merci d'avance 🙂
 

Pièces jointes

Dernière édition:
Bonjour anouarlachiri, Pierre,

Voyez le fichier joint et ces codes, comme demandé au post #1 seules les colonnes G à M sont fusionnées :
VB:
Sub Fusionner()
Dim i&, h&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Feuil1.UsedRange 'CodeName de la feuille
    For i = 1 To .Rows.Count
        If .Cells(i, 2) <> "" Then
            h = .Cells(i, 2).MergeArea.Rows.Count
            If h > 1 Then
                .Cells(i, 7).Resize(h, 7).UnMerge 'défusionne
                For j = 7 To 13 'colonnes G à M
                    .Cells(i, j) = Ajouter(.Cells(i, j).Resize(h), j < 9)
                    .Cells(i, j).Resize(h).Merge 'fusionne
                Next j
            End If
        End If
    Next i
End With
End Sub

Function Ajouter(tablo, concat As Boolean)
Dim i&
tablo = tablo 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If concat Then
        If tablo(i, 1) <> "" Then tablo(1, 1) = tablo(1, 1) & ";" & tablo(i, 1)
    ElseIf IsNumeric(tablo(1, 1)) Then
        If IsNumeric(tablo(i, 1)) Then tablo(1, 1) = CDbl(tablo(1, 1)) + CDbl(tablo(i, 1))
    End If
Next
Ajouter = tablo(1, 1)
End Function
Si vous désirez que le résultat soit dans une autre feuille dites-le.

A+
 

Pièces jointes

Dernière édition:
Merci bien @job75

Votre programme marche bien, par contre comme sur mon fichier joint ( Feuil2 = solution ) j'aimerais que les autres colonne montre que la première valeur rencontré ( comme la Feuil2 de mon fichier joint )

J'espère que j'ai bien expliqué ma problématique 🙂

Merci d'avance
 
Avec ce fichier (2) toutes les colonnes sont traitées sauf la colonne B :
VB:
Sub Fusionner()
Dim ncol%, i&, h&, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Feuil1.UsedRange 'CodeName de la feuille
    ncol = .Columns.Count
    Union(.Columns(1), .Columns(3).Resize(, ncol - 2)).UnMerge 'défusionne toutes les colonnes sauf la colonne B
    For i = 1 To .Rows.Count
        If .Cells(i, 2) <> "" Then
            h = .Cells(i, 2).MergeArea.Rows.Count
            If h > 1 Then
                For j = 1 To ncol
                    If j <> 2 Then
                        .Cells(i, j) = Ajouter(.Cells(i, j).Resize(h), j < 7 Or j > 13, j < 9 Or j > 13)
                        .Cells(i, j).Resize(h).Merge 'fusionne
                    End If
                Next j
            End If
        End If
    Next i
End With
End Sub

Function Ajouter(tablo, premier As Boolean, concat As Boolean)
Dim i&
If premier Then Ajouter = tablo(1, 1): Exit Function
tablo = tablo 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If concat Then
        If tablo(i, 1) <> "" Then tablo(1, 1) = tablo(1, 1) & ";" & tablo(i, 1)
    ElseIf IsNumeric(tablo(1, 1)) Then
        If IsNumeric(tablo(i, 1)) Then tablo(1, 1) = CDbl(tablo(1, 1)) + CDbl(tablo(i, 1))
    End If
Next
Ajouter = tablo(1, 1)
End Function
 

Pièces jointes

Dernière édition:
Cela dit fusionner les cellules n'est pas une très bonne idée, voyez ce fichier (3).

Il s'agit en fait ici d'un regroupement donc il est plus logique de supprimer les lignes devenues inutiles :
VB:
Sub Grouper()
Dim ncol%, i&, h&, j%
Application.ScreenUpdating = False
With Feuil1.UsedRange 'CodeName de la feuille
    ncol = .Columns.Count
    For i = 1 To .Rows.Count
        If .Cells(i, 2) <> "" Then
            h = .Cells(i, 2).MergeArea.Rows.Count
            If h > 1 Then
                For j = 1 To ncol
                    If j <> 2 Then _
                        .Cells(i, j) = Ajouter(.Cells(i, j).Resize(h), j < 7 Or j > 13, j < 9 Or j > 13)
                Next j
            End If
        End If
    Next i
    .Columns(2).UnMerge 'défusionne la colonne B
    On Error Resume Next 'si aucune SpecialCell
    .Offset(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'supprime les lignes devenues inutiles
End With
End Sub

Function Ajouter(tablo, premier As Boolean, concat As Boolean)
Dim i&
If premier Then Ajouter = tablo(1, 1): Exit Function
tablo = tablo 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If concat Then
        If tablo(i, 1) <> "" Then tablo(1, 1) = tablo(1, 1) & ";" & tablo(i, 1)
    ElseIf IsNumeric(tablo(1, 1)) Then
        If IsNumeric(tablo(i, 1)) Then tablo(1, 1) = CDbl(tablo(1, 1)) + CDbl(tablo(i, 1))
    End If
Next
Ajouter = tablo(1, 1)
End Function
 

Pièces jointes

Pour tester j'ai recopié le tableau sur 4800 lignes, durées d'exécution chez moi sur Win 10 - Excel 2013 :

- macro de pierrejean => 8,5 secondes (avec Application.ScreenUpdating = False)

-ma macro du fichier (3) => 2,5 secondes.

On devrait pouvoir faire mieux l'un et l'autre en utilisant des tableaux VBA.
 
Pour tester j'ai recopié le tableau sur 4800 lignes, durées d'exécution chez moi sur Win 10 - Excel 2013 :

- macro de pierrejean => 8,5 secondes (avec Application.ScreenUpdating = False)

-ma macro du fichier (3) => 2,5 secondes.

On devrait pouvoir faire mieux l'un et l'autre en utilisant des tableaux VBA.




Merci @job75 votre programme marche très bien je vais essayer les deux programme pour étudier la durée d’exécution chez moi:

(Win 10 - Excel 2016)

Merci bien meilleur Forum 😉
 
Bonjour anouarlachiri, Pierre, le forum,

Je disais que ce serait plus rapide avec des tableaux VBA, voyez ce fichier (4) :
VB:
Dim tablo, i&, h&, j% 'mémorise les variables

Sub Grouper()
Dim ncol%, n&
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 2 Then ncol = 2
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To UBound(tablo), 1 To ncol)
        For i = 1 To UBound(tablo)
            If tablo(i, 2) <> "" Then
                n = n + 1
                h = .Cells(i, 2).MergeArea.Rows.Count
                For j = 1 To ncol
                    resu(n, j) = Ajouter(j < 7 Or j > 13, j < 9 Or j > 13)
                Next j
            End If
        Next i
        .UnMerge 'RAZ
        .Interior.ColorIndex = xlNone 'RAZ
    End With
    '---restitution---
    If n Then
        With .[A2].Resize(n, ncol)
            .Rows(1).Interior.Color = RGB(192, 210, 226) 'titres
            .Font.Name = "Tahoma"
            .Font.Size = 6
            .Value = resu
        End With
    End If
    .Rows(n + 2).Resize(.Rows.Count - n - 1).Delete 'RAZ en dessous
End With
End Sub

Function Ajouter(premier As Boolean, concat As Boolean)
Dim k&
Ajouter = tablo(i, j)
If premier Then Exit Function
For k = i + 1 To i + h - 1
    If concat Then
        If tablo(k, j) <> "" Then Ajouter = Ajouter & ";" & tablo(k, j)
    ElseIf IsNumeric(tablo(k, j)) Then
        If IsNumeric(tablo(k, j)) Then Ajouter = Ajouter + CDbl(tablo(k, j))
    End If
Next
End Function
Avec un tableau de 4800 lignes la macro s'exécute maintenant en 0,8 seconde.

Bonne journée.
 

Pièces jointes

Bonjour anouarlachiri, Pierre, le forum,

Je disais que ce serait plus rapide avec des tableaux VBA, voyez ce fichier (4) :
VB:
Dim tablo, i&, h&, j% 'mémorise les variables

Sub Grouper()
Dim ncol%, n&
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
    With .UsedRange
        ncol = .Columns.Count
        If ncol < 2 Then ncol = 2
        tablo = .Resize(, ncol) 'matrice, plus rapide
        ReDim resu(1 To UBound(tablo), 1 To ncol)
        For i = 1 To UBound(tablo)
            If tablo(i, 2) <> "" Then
                n = n + 1
                h = .Cells(i, 2).MergeArea.Rows.Count
                For j = 1 To ncol
                    resu(n, j) = Ajouter(j < 7 Or j > 13, j < 9 Or j > 13)
                Next j
            End If
        Next i
        .UnMerge 'RAZ
        .Interior.ColorIndex = xlNone 'RAZ
    End With
    '---restitution---
    If n Then
        With .[A2].Resize(n, ncol)
            .Rows(1).Interior.Color = RGB(192, 210, 226) 'titres
            .Font.Name = "Tahoma"
            .Font.Size = 6
            .Value = resu
        End With
    End If
    .Rows(n + 2).Resize(.Rows.Count - n - 1).Delete 'RAZ en dessous
End With
End Sub

Function Ajouter(premier As Boolean, concat As Boolean)
Dim k&
Ajouter = tablo(i, j)
If premier Then Exit Function
For k = i + 1 To i + h - 1
    If concat Then
        If tablo(k, j) <> "" Then Ajouter = Ajouter & ";" & tablo(k, j)
    ElseIf IsNumeric(tablo(k, j)) Then
        If IsNumeric(tablo(k, j)) Then Ajouter = Ajouter + CDbl(tablo(k, j))
    End If
Next
End Function
Avec un tableau de 4800 lignes la macro s'exécute maintenant en 0,8 seconde.

Bonne journée.
  • Lien supprimé
Rebonjour @job75;

Votre programme est très efficace 😉

Merci infiniment 🙂
 
- 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
9
Affichages
415
Réponses
4
Affichages
105
Réponses
3
Affichages
298
Retour