IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Regrouper un tableau "tblbd" par compte avec sous.total par vba [XL-365]


Sujet :

Macros et VBA Excel

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre éclairé
    Homme Profil pro
    comptable principal
    Inscrit en
    Octobre 2010
    Messages
    434
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : Autre

    Informations professionnelles :
    Activité : comptable principal
    Secteur : Finance

    Informations forums :
    Inscription : Octobre 2010
    Messages : 434
    Par défaut Regrouper un tableau "tblbd" par compte avec sous.total par vba
    Bonsoir
    svp je souhaite améliorer le temps d'exécution de mon code qui regroupe un tableau "tblbd" par compte et ajoute a la fin de chaque groupe de compte un sous.total

    voici le code

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    Sub Regroupe_par_compte()
     With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
    End With
    Dim T#
    T = Timer
     
        Set Base = Sheets("feuil1")
        Set Resultat = Sheets("feuil2")
        Dim d1 As New Dictionary
        tblbd = Base.Range("A6:G11839")
     
        For i = 1 To UBound(tblbd)
            d1(tblbd(i, 5)) = d1(tblbd(i, 5)) + tblbd(i, 7)
        Next i
        j = 6
     
        For Each Eleme In d1
     
            For i = 1 To UBound(tblbd)
                If tblbd(i, 5) = Eleme Then
                    Resultat.Range("A" & j) = tblbd(i, 1)
                    Resultat.Range("B" & j) = tblbd(i, 2)
                    Resultat.Range("C" & j) = tblbd(i, 3)
                    Resultat.Range("D" & j) = tblbd(i, 4)
                    Resultat.Range("E" & j) = tblbd(i, 5)
                    Resultat.Range("F" & j) = tblbd(i, 6)
                    Resultat.Range("G" & j) = tblbd(i, 7)
                    j = j + 1
                 End If
            Next i
     
            Resultat.Range("A" & j) = "Total Du Compte " & Eleme
            Resultat.Range("G" & j) = d1.Item(Eleme)
            Resultat.Range("A" & j & ":G" & j).Interior.Color = 65535
            Resultat.Range("A" & j & ":G" & j).Font.Bold = True
     
            j = j + 1
        Next Eleme
    Resultat.Columns("G:G").NumberFormat = "#,##0.00"
     
    With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
    End With
     
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
    End Sub
    j'ai pensé de diminuer la boucle If tblbd(i, 5) = Eleme le maximum comme suivant :

    exemple si le nombre du Eleme est 12 alors je doit mettre un compteur dans cette if et si le compteur = Eleme alors Next Eleme
    et ça évité la boucle de tester tous les lignes du tableau mais j'ai pas pu écrire le bon code
    le tableau contient 400000 lignes

    merci

  2. #2
    Membre Expert
    Inscrit en
    Décembre 2002
    Messages
    993
    Détails du profil
    Informations forums :
    Inscription : Décembre 2002
    Messages : 993
    Par défaut
    Salut, essaie comme ceci:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    Sub Regroupe_par_compte()
    Dim T As Double
    T = Timer
     
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
     
    Dim Base As Worksheet
    Set Base = ThisWorkbook.Sheets("feuil1")
     
    Dim Resultat As Worksheet
    Set Resultat = ThisWorkbook.Sheets("feuil2")
     
    Dim tblbd As Variant
    tblbd = Base.Range("A6:G11839").Value 'Modifier la plage en fonction de votre besoin
     
    Dim dictComptes As New Scripting.Dictionary
     
    'Récupérer le total par compte
    Dim i As Long
    For i = 1 To UBound(tblbd)
        dictComptes(tblbd(i, 5)) = dictComptes(tblbd(i, 5)) + tblbd(i, 7)
    Next i
     
    'Copier le résultat dans la feuille de résultat
    Dim lastRow As Long
    lastRow = 5 'Numéro de la première ligne pour coller les données dans la feuille de résultat
    Dim compte As Variant
    For Each compte In dictComptes.Keys
        Base.Range("A5:G" & UBound(tblbd, 1)).AutoFilter Field:=5, Criteria1:=compte
        Dim rangeFiltree As Range
        Set rangeFiltree = Base.Range("A5:G" & UBound(tblbd, 1)).SpecialCells(xlCellTypeVisible)
        rangeFiltree.Copy Destination:=Resultat.Range("A" & lastRow)
        lastRow = lastRow + rangeFiltree.Rows.Count
        Resultat.Range("A" & lastRow) = "Total Du Compte " & compte
        Resultat.Range("G" & lastRow) = dictComptes(compte)
        Resultat.Range("A" & lastRow & ":G" & lastRow).Interior.Color = 65535
        Resultat.Range("A" & lastRow & ":G" & lastRow).Font.Bold = True
        lastRow = lastRow + 1
    Next compte
     
    Resultat.Columns("G:G").NumberFormat = "#,##0.00"
     
    Base.AutoFilterMode = False
     
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
     
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
     
    End Sub
    La méthode .AutoFilter devrait accélérer le traitement mais je ne sais pas dans quelle mesure, à toi de voir.

  3. #3
    Membre éclairé
    Homme Profil pro
    comptable principal
    Inscrit en
    Octobre 2010
    Messages
    434
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : Autre

    Informations professionnelles :
    Activité : comptable principal
    Secteur : Finance

    Informations forums :
    Inscription : Octobre 2010
    Messages : 434
    Par défaut
    bonjour Mr Franc
    merci pour votre réponse
    voici un fichier teste pour voire le résultat des codes
    Fichiers attachés Fichiers attachés

  4. #4
    Membre Expert
    Inscrit en
    Décembre 2002
    Messages
    993
    Détails du profil
    Informations forums :
    Inscription : Décembre 2002
    Messages : 993
    Par défaut
    Salut, c'est tout de suite mieux avec un classeur exemple. Avec la sub ci-dessous on gagne environ 25%, 1.65 sec. contre 2.24 pour ton code.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    Sub Regroupe_par_compte()
        With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
        End With
     
        Dim T#
        T = Timer
     
        Set Base = Sheets("feuil1")
        Set Resultat = Sheets("feuil2")
        Dim d1 As New Dictionary
        tblbd = Base.Range("A6:G11839")
        Resultat.Range("A6:G20000").Clear
     
        ' Utilisation d'un tableau pour stocker les données
        Dim data() As Variant
        data = tblbd
     
        ' Utilisation d'un dictionnaire pour stocker les résultats intermédiaires
        Dim d2 As New Dictionary
     
        For i = 1 To UBound(data)
            d1(data(i, 5)) = d1(data(i, 5)) + data(i, 7)
            If Not d2.Exists(data(i, 5)) Then
                d2(data(i, 5)) = i
            End If
        Next i
     
        j = 6
     
        ' Variable pour stocker le grand total
        Dim grandTotal As Double
        grandTotal = 0
     
        For Each Eleme In d1.Keys
     
            ' Affichage de toutes les lignes faisant partie du même compte
            For i = 1 To UBound(data)
                If data(i, 5) = Eleme Then
                    Resultat.Cells(j, 1) = data(i, 1)
                    Resultat.Cells(j, 2) = data(i, 2)
                    Resultat.Cells(j, 3) = data(i, 3)
                    Resultat.Cells(j, 4) = data(i, 4)
                    Resultat.Cells(j, 5) = data(i, 5)
                    Resultat.Cells(j, 6) = data(i, 6)
                    Resultat.Cells(j, 7) = data(i, 7)
                    j = j + 1
                End If
            Next i
     
            Resultat.Cells(j, 1) = "Total Du Compte " & Eleme
            Resultat.Cells(j, 7) = d1.Item(Eleme)
            Resultat.Range("A" & j & ":G" & j).Interior.Color = 65535
            Resultat.Range("A" & j & ":G" & j).Font.Bold = True
     
            ' Mise à jour du grand total
            grandTotal = grandTotal + d1.Item(Eleme)
     
            j = j + 1
        Next Eleme
     
        ' Affichage du grand total à la dernière ligne
        Resultat.Cells(j, 1) = "Grand Total"
        Resultat.Cells(j, 7) = grandTotal
        Resultat.Range("A" & j & ":G" & j).Interior.ColorIndex = xlNone
        Resultat.Range("A" & j & ":G" & j).Font.Bold = True
     
        Resultat.Columns("G:G").NumberFormat = "#,##0.00"
     
        With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
     
        MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
    End Sub
    Celle-ci est encore plus rapide mais je ne sais pas si elle peut te convenir, elle affiche uniquement les sous-totaux par compte et le grand total, elle s'exécute en 0.05 secondes.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    Sub Regroupe_par_compte()
        With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
        End With
     
        Dim T#
        T = Timer
     
        Set Base = Sheets("feuil1")
        Set Resultat = Sheets("feuil2")
        Dim d1 As New Dictionary
        tblbd = Base.Range("A6:G11839")
        Resultat.Range("A6:G20000").Clear
     
        ' Utilisation d'un tableau pour stocker les données
        Dim data() As Variant
        data = tblbd
     
        ' Utilisation d'un dictionnaire pour stocker les résultats intermédiaires
        Dim d2 As New Dictionary
     
        For i = 1 To UBound(data)
            d1(data(i, 5)) = d1(data(i, 5)) + data(i, 7)
            If Not d2.Exists(data(i, 5)) Then
                d2(data(i, 5)) = i
            End If
        Next i
     
        j = 6
     
        ' Variable pour stocker le grand total
        Dim grandTotal As Double
        grandTotal = 0
     
        For Each Eleme In d1.Keys
     
            Resultat.Cells(j, 1) = "Total Du Compte " & Eleme
            Resultat.Cells(j, 7) = d1.Item(Eleme)
            Resultat.Range("A" & j & ":G" & j).Interior.ColorIndex = xlNone
            Resultat.Range("A" & j & ":G" & j).Font.Bold = True
     
            ' Mise à jour du grand total
            grandTotal = grandTotal + d1.Item(Eleme)
     
            j = j + 1
        Next Eleme
     
        ' Affichage du grand total à la dernière ligne
        Resultat.Cells(j, 1) = "Grand Total"
        Resultat.Cells(j, 7) = grandTotal
        Resultat.Range("A" & j & ":G" & j).Interior.ColorIndex = xlNone
        Resultat.Range("A" & j & ":G" & j).Font.Bold = True
     
        Resultat.Columns("G:G").NumberFormat = "#,##0.00"
     
        With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
     
        MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
    End Sub

  5. #5
    Membre éclairé
    Homme Profil pro
    comptable principal
    Inscrit en
    Octobre 2010
    Messages
    434
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : Autre

    Informations professionnelles :
    Activité : comptable principal
    Secteur : Finance

    Informations forums :
    Inscription : Octobre 2010
    Messages : 434
    Par défaut
    Merci Beaucoup Mr Franc
    j'ai trouver une solution très très rapide avec le filtre avancé
    j'ai simplement ajouter la zone de cristaire

    et voici le code

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    Sub par_filtre_avancé()
    Dim T#
    T = Timer
    With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
    End With
     
        Set Base = Sheets("feuil1")
        Set Resultat = Sheets("feuil2")
        Dim d1 As New Dictionary
        Dim d2 As New Dictionary
        tblbd = Base.Range("A6:G11839")
        Dim data() As Variant
        data = tblbd
        RgCriter = Base.Range("I1:O2")
        Resultat.Range("A6:G20000").Clear
     
    For i = 1 To UBound(data)
            d1(data(i, 5)) = d1(data(i, 5)) + data(i, 7)
            d2(data(i, 5)) = d2(data(i, 5)) + 1
    Next i
    Dim grandTotal As Double
        grandTotal = 0
    For Each Eleme In d1.Keys
        P = d2.Item(Eleme)
        Base.Range("M2").Value = Eleme
        LASTROW = Resultat.Cells(Resultat.Rows.Count, 1).End(xlUp).Row + 1
        Base.Range("Tableau1[#All]").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Base.Range("Tableau2[#All]"), CopyToRange:=Resultat.Cells(LASTROW, 1)
     
        Resultat.Rows(LASTROW & ":" & LASTROW).Delete Shift:=xlUp
        Resultat.Range("A" & P + LASTROW) = "Total Du Compte " & Eleme
        Resultat.Range("G" & P + LASTROW) = d1.Item(Eleme)
        Resultat.Range("A" & P + LASTROW & ":G" & P + LASTROW).Interior.Color = 65535
        Resultat.Range("A" & P + LASTROW & ":G" & P + LASTROW).Font.Bold = True
        grandTotal = grandTotal + d1.Item(Eleme)
     
    Next Eleme
    LASTROW = Resultat.Cells(Resultat.Rows.Count, 1).End(xlUp).Row + 1
    Resultat.Cells(LASTROW, 1) = "Grand Total"
    Resultat.Cells(LASTROW, 7) = grandTotal
     
    Resultat.Columns("G:G").NumberFormat = "#,##0.00"
     
    With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With
     
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec"), , "Import"
     
    End Sub

  6. #6
    Rédacteur
    Avatar de Philippe Tulliez
    Homme Profil pro
    Formateur, développeur et consultant Excel, Access, Word et VBA
    Inscrit en
    Janvier 2010
    Messages
    13 173
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Belgique

    Informations professionnelles :
    Activité : Formateur, développeur et consultant Excel, Access, Word et VBA

    Informations forums :
    Inscription : Janvier 2010
    Messages : 13 173
    Billets dans le blog
    53
    Par défaut
    Bonjour,
    Il existe une fonctionnalité native d'excel qui effectue le sous-total d'une colonne en faisant la somme, la moyenne, etc. de celle-ci, en VBA c'est la méthode SubTotal,
    Cette fonctionnalité est devenu un obsolète depuis l'utilisation des tableaux structurés qui ne permettent pas d'ailleurs l'usage de cette fonctionnalité.

    Avec un tableau structuré et le tableau croisé dynamique on regroupe et on fait la somme en trois clics

    Cependant si vous souhaitez tout de même l'utiliser, j'ai retrouvé dans mes archives une fonction générique qui fait le job

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    Function SubTotalRangeColumn(oRange As Range, _
                                 FieldToGroup As String, _
                                 FieldTotal As String, _
                                 ConsolidationFunction As XlConsolidationFunction, _
                                 Optional AddGrouping As Boolean, _
                                 Optional WithOutLineMode As Boolean)
     ' Effectue le sous-total d'une colonne par regroupement
     ' La colonne à regrouper doit être triée
     ' Philippe Tulliez (https://magicoffice.be)
     ' Arguments
     '  oRange                 Plage concernée par le regroupement
     '  FieldToGroup           Nom de la colonne à regrouper
     '  FieldTotal             Nom de la colonne dont on veut faire la synthèse
     '  ConsolidationFunction  Fonction de synthèse
     '  [AddGrouping]          True si l'on veut ajouter un regroupement
     '  [WithOutLineMode]      True si l'on veut laisser le mode plan
     Dim fx As WorksheetFunction
     Set fx = Application.WorksheetFunction
     Dim t As Integer
     Dim g As Integer
     With fx
       g = .Match(FieldToGroup, oRange.Resize(1), 0)
       t = .Match(FieldTotal, oRange.Resize(1), 0)
     End With
     With oRange
     .Subtotal GroupBy:=g, _
               Function:=ConsolidationFunction, _
               TotalList:=Array(t), _
               Replace:=Not AddGrouping, _
               SummaryBelowData:=True
      If Not WithOutLineMode Then .Cells(1, 1).ClearOutline
     End With
     Set fx = Nothing
    End Function
    Exemple d'une fonction qui l'invoque
    Dans cet exemple, on effectue la somme de la colonne nommée CA par regroupement des éléments de la colonne Région d'une plage de cellules débutant en cellule A1 de la feuille nommée Chiffre d'affaires du classeur où se trouve le code VBA (ThisWorkbook)
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    Sub TestSubTotalRangeColumn()
       Const SheetName As String = "Chiffre d'affaires"
       Const FieldToGroup As String = "Région"
       Const LabelSum As String = "CA"
       Dim rng As Range
       Set rng = ThisWorkbook.Worksheets(SheetName).Range("A1").CurrentRegion
       SubTotalRangeColumn oRange:=rng, FieldToGroup:=FieldToGroup, FieldTotal:=LabelSum, ConsolidationFunction:=xlSum
       Set rng = Nothing
    End Sub
    Philippe Tulliez
    Ce que l'on conçoit bien s'énonce clairement, et les mots pour le dire arrivent aisément. (Nicolas Boileau)
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter
    Mes tutoriels : Utilisation de l'assistant « Insertion de fonction », Les filtres avancés ou élaborés dans Excel
    Mon dernier billet : Utilisation de la fonction Dir en VBA pour vérifier l'existence d'un fichier

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Réponses: 3
    Dernier message: 23/07/2021, 14h59
  2. Réponses: 12
    Dernier message: 07/04/2016, 09h08
  3. Remplacer caractère ' ( quote ) par "\n"
    Par Eric45 dans le forum C++
    Réponses: 3
    Dernier message: 28/11/2007, 00h56
  4. Réponses: 5
    Dernier message: 30/05/2005, 16h58

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo