Optimisation vitesse de calcul

Le 30/11/2017 à 09:20

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?

Private Sub RemplissageTableau()
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
                        End If

                        If (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
                        End If

                        If (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

End Sub

Derlign vaut "221" et dercol "52".

Merci à vous

Le 30/11/2017 à 10:15

Bonjour,

as-tu des formules et des mises en forme conditionnelles dans ton fichier ? merci de nous mettre une version du fichier dans lequel on peut voir ton problème de performance.

Le 30/11/2017 à 10:18

Bonjour,

un essai :

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

Ajout de trois instructions qui fiche l'écran, arrête les calculs et inhibe la surveillances des événements.

Ensuite on réactive ces trois choses.

Raccourcis de IF en mettant des ElseIf car si dans la boucle on a (tabBDD(cptBDD, 1) = crit2) alors il ne peut être égal à crit5 ou crit6 sur la même boucle, cela supprime deux tests....

Sans fichier je n'ai pas pu essayer...

@ bientôt

LouReeD

Le 30/11/2017 à 10:28

Merci LouReeD,

J'ai testé ta solution, et le temps est encore 2minutes et 6s contre 2minutes et 10s pour l'autre code, un gain de 4s.

Je précise tabBDD est sur 55000 lignes et 31 colonnes, sa fait pas mal de cellules à traiter

quand j'ai vu ton code je me suis dis que le gain allait être énorme mais en fait pas temps que ça.

Est ce que tu penses que du fait que TabBDD est grand je ne pourrais pas gagner beaucoup plus, ou est ce qu'il y aurait une autre méthode, par exemple changer la boucle For par une autre boucle qui serait plus rapide ?

Merci

h2so4 a écrit :

Bonjour,

as-tu des formules et des mises en forme conditionnelles dans ton fichier ? merci de nous mettre une version du fichier dans lequel on peut voir ton problème de performance.

Bonjour h2so4, dans la feuille BDD je n'ai que des valeurs bruts, aucune formules ni MFC, c'est la macro qui additionne les valeurs de TabBDD en fonction des critères pour par la suite les afficher sur la feuille "Family & Country"

Le 30/11/2017 à 11:09

Bonjour,

mets-nous un fichier pour voir ce qu'on peut faire ...

Le 30/11/2017 à 13:33

Il y a aussi l'idée de travailler en "tout VBA" tableau source comme tableau résultat.

Au lieu que chaque calcul s'inscrive sur la feuille wsResult, ils s'inscrivent dans un tableau VBA de "même dimension".Une fois la boucle terminée il suffit d'attribuer le tableau VBA Résult à la zone voulue sur la feuille wsResult.

@ bientôt

LouReeD

Le 30/11/2017 à 14:34

Je suis actuellement essayé de faire un code en "tout VBA", je vais le poster une fois que celui ci sera fini afin d'avoir vos impressions.

Le 30/11/2017 à 15:47
LouReeD a écrit :

Il y a aussi l'idée de travailler en "tout VBA" tableau source comme tableau résultat.

Au lieu que chaque calcul s'inscrive sur la feuille wsResult, ils s'inscrivent dans un tableau VBA de "même dimension".Une fois la boucle terminée il suffit d'attribuer le tableau VBA Résult à la zone voulue sur la feuille wsResult.

@ bientôt

LouReeD

J'ai essayé un code qui m'a pris pas mal de temps et qui ne fonctionne pas du tout , voici mon code pour te faire vois la démarche que j'ai voulu appliquer;

Option Base 1
Sub test()

Dim wsBDD As Object
Dim wsResult As Object
Dim tabBDD
Dim som(19)
Dim Ncol As Integer, Nlgn As Long, cptBDD As Long, dercol As Integer
Dim crit(5)
'
Set wsBDD = Worksheets("BDD")
Set wsResult = Worksheets("Familly & Country")
'
Application.ScreenUpdating = False
'
With wsBDD
    tabBDD = .Range("A3:AE" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
'
With wsResult

derlgn = Range("B" & Rows.Count).End(xlUp).Row
dercol = Cells(2, Columns.Count).End(xlToLeft).Column

    For Ncol = 4 To dercol

        For Nlgn = 2 To derlgn Step 4
            Erase som

                crit1 = Sheets("Données").Cells(4, 2) ' Réél ( n )
                crit2 = .Cells(1, Nlgn) ' Country
                crit3 = .Cells(8, Ncol) ' Familly
                crit4 = Sheets("Données").Cells(5, 2) ' YTD ACT ( n )
                crit5 = Sheets("Données").Cells(6, 2) ' YTD ACT ( n - 1 )

                    For cptBDD = 1 To UBound(tabBDD, 1)
                        If (tabBDD(cptBDD, 1) = crit1) And (tabBDD(cptBDD, 30) = crit2) And (tabBDD(cptBDD, 24) = crit3) Then iIdx = 0
                        If (tabBDD(cptBDD, 1) = crit4) And (tabBDD(cptBDD, 30) = crit2) And (tabBDD(cptBDD, 24) = crit3) Then iIdx = 1
                        If (tabBDD(cptBDD, 1) = crit5) And (tabBDD(cptBDD, 30) = crit2) And (tabBDD(cptBDD, 24) = crit3) Then iIdx = 2
                            som(1 + (iIdx * 4)) = som(1 + (iIdx * 4)) + tabBDD(cptBDD, 11)
                            som(2 + (iIdx * 4)) = som(2 + (iIdx * 4)) + tabBDD(cptBDD, 12)
                            som(3 + (iIdx * 4)) = som(3 + (iIdx * 4)) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                            som(4 + (iIdx * 4)) = som(3 + (iIdx * 4)) / som(2 + (iIdx * 4))

                            For x = 1 To 4

                                        For i = 1 To derlgn

                                        .Cells((x + 1 + i), Ncol) = som(x + (iIdx * 4))

                                        Next
                            Next
                    Next

    Next
        Next
End With
'
Set wsBDD = Nothing
Set wsResult = Nothing
'
Application.ScreenUpdating = True
End Sub

Est ce que tu pourrais me guider afin de faire un code en "Tableau VBA" stp ?

Rechercher des sujets similaires à "optimisation vitesse calcul"