Regrouper un tableau "tblbd" par compte avec sous.total par vba

Version imprimable

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:

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

Salut, essaie comme ceci:

Code:

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.

27/04/2023, 17h12
iliesss

1 pièce(s) jointe(s)

bonjour Mr Franc
merci pour votre réponse
voici un fichier teste pour voire le résultat des codes

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:

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:

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

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:

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

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:

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:

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

30/04/2023, 14h05
iliesss

1 pièce(s) jointe(s)

Bonjour Mr Philippe
Merci pour la réponse
j'ai essayé d'appliqué vos code mais je suis bloqué dans la ligne N°22 de la Function

Pièce jointe 638065