VBA: conditions des cellules fusionner

[Anr1]

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

 

[pierrejean]

Bonjour anouarlachiri

Comment traiter la colonne A ?

 

[Anr1]

Bonjour @pierrejean

Comme le reste des autres colonnes j'aimerais laisser la première valeur.

Merci pour votre réactivité

 

[job75]

Bonjour anouarlachiri, Pierre,

Voyez le fichier joint et ces codes, comme demandé au post #1 seules les colonnes G à M sont fusionnées :

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+

 

[Anr1]

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

 

[pierrejean]

Re
Salut Gerard
Ma version

 

[job75]

Avec ce fichier (2) toutes les colonnes sont traitées sauf la colonne B :

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

 

[job75]

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 :

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

 

[job75]

Je viens d'ouvrir et tester le fichier de pierrejean.

C'est le résultat de mon fichier (3) et c'est bien plus simple

A+

 

[job75]

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.

 

[Anr1]

Re
Salut Gerard
Ma version

Merci bcp @pierrejean pour votre programme il marche parfaitement comme je veux

Bonne journée

 

[Anr1]

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

 

[job75]

Bonjour anouarlachiri, Pierre, le forum,

Je disais que ce serait plus rapide avec des tableaux VBA, voyez ce fichier (4) :

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.

 

[Anr1]

Bonjour anouarlachiri, Pierre, le forum,

Je disais que ce serait plus rapide avec des tableaux VBA, voyez ce fichier (4) :

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