Bonjour à tous, j'ai réalisé la macro ci dessous:

Elle fonctionne parfaitement par contre son temps d’exécution est d'environ 2 minutes, c'est la boucle " For i " qui prends enormement de temps.

Est ce qu'il y aurait une écriture différente afin d'optimiser la vitesse de calcul? Derlign vaut "221" et dercol "52".
Et la TabBDD dispose de 55000 lignes et 51 colonnes

Code vb : 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
Private Sub RemplissageTableau()
Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Dim tabBDD()
    Dim wsBDD As Object
    Dim wsResult As Object
    Dim som(9)
    Dim crit(6)
    Dim cptBDD
    Dim i, j As Long
    Set wsBDD = Worksheets("BDD")
    Set wsResult = Worksheets("Familly & Country")
    With wsBDD
        tabBDD = Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 30)) ' Définition du tableau de travail
   End With
    With wsResult
        derlig = Cells(Rows.Count, 2).End(xlUp).Offset(0, 0).Row
        dercol = Cells(1, Cells.Columns.Count).End(xlToLeft).Offset(0, 0).Column
        For i = 2 To derlig Step 4
            For j = 4 To dercol
                som1 = 0
                som2 = 0
                som3 = 0
                som4 = 0
                som5 = 0
                som6 = 0
                som7 = 0
                som8 = 0
                som9 = 0
                crit2 = Sheets("Données").Cells(4, 2)  'Réel
               crit3 = Sheets("Familly & Country").Cells(i, 1) ' Country
               crit4 = Sheets("Familly & Country").Cells(1, j) 'Familly
               crit5 = Sheets("Données").Cells(5, 2) 'YTD  n
               crit6 = Sheets("Données").Cells(6, 2) 'YTD  n-1
               For cptBDD = 1 To UBound(tabBDD, 1)
                    If (tabBDD(cptBDD, 1) = crit2) And (tabBDD(cptBDD, 30) = crit3) And (tabBDD(cptBDD, 24) = crit4) Then
                        som1 = som1 + tabBDD(cptBDD, 11) 'total1
                       som2 = som2 + tabBDD(cptBDD, 12) 'total2
                       som3 = som3 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'total3
                   ElseIf (tabBDD(cptBDD, 1) = crit5) And (tabBDD(cptBDD, 30) = crit3) And (tabBDD(cptBDD, 24) = crit4) Then
                        som4 = som4 + tabBDD(cptBDD, 11) 'total1
                       som5 = som5 + tabBDD(cptBDD, 12) 'total2
                       som6 = som6 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'total3
                   ElseIf (tabBDD(cptBDD, 1) = crit6) And (tabBDD(cptBDD, 30) = crit3) And (tabBDD(cptBDD, 24) = crit4) Then
                        som7 = som7 + tabBDD(cptBDD, 11) 'total1
                       som8 = som8 + tabBDD(cptBDD, 12) 'total2
                       som9 = som9 + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'total3
                   End If
                Next
                .Cells(i, j) = som1 + som4 - som7 'Total 1
               .Cells(i + 1, j) = (som2 + som5 - som8) 'Total 2
               .Cells(i + 2, j) = ((som3 + som6 - som9) * -1) 'Total 3
               If (som2 + som5 - som8) <= 0 Then
                    .Cells(i + 3, j) = 0
                Else
                    .Cells(i + 3, j) = ((som3 + som6 - som9) * -1) / (som2 + som5 - som8) ' %Total
               End If
            Next
        Next
    End With
    Cells.EntireColumn.AutoFit
Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Merci à vous