Autres Tableaux virtuels très lents..

[Calvus]

Bonjour le forum,

J'ai l'habitude de manipuler des tableaux en VBA, notamment pour le gain en vitesse et la maniabilité, mais je suis confronté à une nouveauté !

La macro présente dans le fichier fonctionne très bien mais est d'une extrême lenteur. Près de 100 secondes, et même un peu plus dans mon fichier original qui va chercher les données dans un autre classeur. (J'ai ajouté une feuille dans le classeur exemple pour plus de simplicité, donc sans ouverture d'autre classeur)

Habituellement le temps de traitement n'excède pas quelques secondes.

J'ai eu beau chercher, je ne vois pas. L'écriture du code me semble correcte et ne diffère pas de ce que j'ai l'habitude de faire.
Un œil neuf verra peut être quelque chose qui m'a échappé.

Fonctionnement de la macro :
Elle va chercher et classer les achats de chaque fournisseur par année, pour chaque client.
Création de 2 dictionnaires, réalisation d'un tableau, et ensuite traitement du tableau pour le résultat final.
C'est là le point qui pose problème et ralentit le code. J'ai mis un commentaire visible sur le code.

Enfin écriture du tableau final sur la feuille : Fourn Par Client
Le bouton Calcul permet le lancement de la macro.
Les 2 autres feuille contiennent les données.

Le Checkbox "Avec Montant" permet de désactiver une partie du code, à savoir ne pas traiter les données par année, et là le code s'exécute en 1,32 secondes seulement.

Merci de votre aide et bon dimanche.

 

[Staple1600]

Re

Re,

Oui mais cela ne change pas la longueur du code pour tout le reste.

Non, mais je n'aime pas les boucles
(surtout les dimanches!
Et encore plus quand le XV de France n'arrive pas à boucler)

 

[Calvus]

Re,

Merci @sylvanu

Je dois m'absenter un moment, je regarderaiet étudierai à mon retour ou ce soir, mais juste pour te signaler que les résultats sont erronés pour l'instant..

Et encore plus quand le XV de France n'arrive pas à boucler)

Pourquoi ? Il y arrive des fois ??
A+

 

[sylvanu]

Re,
C'est fort possible que les résultats soient erronés à cause des indices utilisés ( +/-1) vérifier les indices des arrays, ceux qui commencent en 1, et ceux qui commencent en 0.
Je me suis attaché à réduire le temps, sans prêter trop d'attention aux indices utilisés.
Mais la structure et le principe sont bons.

 

[dg62]

Bonjour le fil,
Sylvanu pour le case an3 tu à fait une erreur de frappe "Somme2=somme3+valround
le code tourne en 8.76 s chez moi. Beau travail.

Select Case NoYear
                    Case an1
                        somme = somme + Valround
                    Case an2
                        somme2 = somme2 + Valround
                    Case an3
                        somme2 = somme3 + Valround
                    Case an2
                        somme4 = somme4 + Valround
                    Case an2
                        somme5 = somme5 + Valround
                End Select

 

[sylvanu]

Exact, merci DG.
Il y avait aussi les Case 1,2,3,2,2,

 

[Calvus]

Bonsoir, sylvanu, Staple, dg62, le forum,,


Merci @sylvanu
Ça fonctionne très bien en une dizaine de secondes maintenant.
Et 45 sur mon fichier original, mais cela est dû à l'ouverture de l'autre classeur je pense
J'aurai appris l'astuce des arrays aujourd'hui !

Il y avait une petite erreur dans ton fichier

        ArrayValround(i - 2) = Round(Sheets("Mvts Stock").Range("U" & i), 2)

Que j'ai corrigée

        ArrayValround(i - 2) = Round(Sheets("Mvts Stock").Range("V" & i), 2)

Et la déclaration de Valround en Double pour avoir une exactitude des résultats.

Par pure curiosité, penses tu qu'il y aurait un moyen d'accélérer encore ?

A+

 

[Calvus]

Re,

Vraiment merci !
J'ai réduit le temps de moitié sur ce fichier exemple, soit à 6 secondes, en transformant tout en Arrays.
C'est magique.

Option Explicit

Sub F_Par_Client()
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With

Dim fFourn As Worksheet, fClients As Worksheet, tClients
Dim tabfin, i%, Annee As String

Dim start As Single
start = Timer

Set fFourn = Sheets("Fourn Par Client")
Set fClients = Sheets("Clients")
Set tabfin = fFourn.ListObjects("Tableau16")
tClients = fClients.Range("B3:P" & fClients.Range("B" & Rows.Count).End(xlUp).Row)
Annee = fFourn.Range("B2")

'Effacement du 1er tableau
'For i = Range("B" & Rows.Count).End(xlUp).Row - 4 To 1 Step -1
'    With tabfin
'        .ListRows(i).Range.Delete
'    End With
'Next i


Dim fMvtStock As Worksheet, fVentes As Worksheet, tMvtStock, tCommandes, a(), b()
Dim j%, n%, m%, k%

Set fMvtStock = Sheets("Mvts Stock")

tMvtStock = fMvtStock.Range("B3:V" & fMvtStock.Range("B" & Rows.Count).End(xlUp).Row)
        
'MsgBox "Durée du traitement: " & Timer - start & " secondes"

Dim dcli, dfourn
Set dcli = CreateObject("Scripting.Dictionary")
Set dfourn = CreateObject("Scripting.Dictionary")
dcli.CompareMode = vbTextCompare
dfourn.CompareMode = vbTextCompare

'Dico pour les clients
For i = 1 To UBound(tMvtStock)
    For j = 1 To UBound(tClients)

    If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
    And Year(tMvtStock(i, 1)) >= Annee Then
        dcli(tMvtStock(i, 6)) = tMvtStock(i, 6)
    End If
    Next j
Next i

'Dico pour les fournisseurs
For i = 1 To UBound(tMvtStock)
    For j = 1 To UBound(tClients)

    If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
    And Year(tMvtStock(i, 1)) >= Annee Then
        dfourn(tMvtStock(i, 5)) = tMvtStock(i, 5)
    End If
    Next j
Next i

Dim c As Variant, cc As Variant

ReDim a(1 To UBound(tMvtStock), 1 To 6)
n = 1
For Each c In dcli.keys
'Debug.Print d.Count
'Debug.Print d(c)
    a(n, 1) = c
    n = n + 1
Next c

ReDim b(1 To UBound(tMvtStock), 1 To 6)
m = 1
For Each c In dfourn.keys
'Debug.Print d.Count
'Debug.Print d(c)
    b(m, 1) = c
    m = m + 1
Next c


ReDim tFinal(1 To UBound(tMvtStock), 1 To 16)

Dim pool As Boolean
n = 1
For Each c In dcli.keys
    For Each cc In dfourn.keys
        pool = False
        For i = 1 To UBound(tMvtStock)
            If tMvtStock(i, 6) = c And tMvtStock(i, 5) = cc Then
                tFinal(n, 1) = tMvtStock(i, 6)
                tFinal(n, 11) = tMvtStock(i, 5)
                    For j = 1 To UBound(tClients)
                        If tMvtStock(i, 6) = tClients(j, 1) Then
                            For k = 2 To 3
                                tFinal(n, k) = tClients(j, k)
                            Next k
                            For k = 4 To 8
                                tFinal(n, k) = tClients(j, k + 2)
                            Next k
                            For k = 9 To 10
                                tFinal(n, k) = tClients(j, k + 3)
                            Next k

                        End If
                    Next j
                    pool = True
            End If
        Next i
            If pool Then n = n + 1
    Next cc
Next c
'PARTIE POSANT PROBLEME
'PARTIE POSANT PROBLEME
If fFourn.Range("F1") = "GO" Then
    Dim an1 As String, an2 As String, an3 As String, an4 As String, an5 As String, Valround As Double
    Dim Taille As Long
    Dim NoYear As Variant
    
    an1 = Range("M3")
    an2 = Range("N3")
    an3 = Range("O3")
    an4 = Range("P3")
    an5 = Range("Q3")
    Dim somme As Double, somme2 As Double, somme3 As Double, somme4 As Double, somme5 As Double
    Dim Val1 As Long, Val2 As Long
    Dim ArrayDates(), ArrayValround(), ArraytFinal(), ArraytMvtStock()
    Taille = Sheets("Mvts Stock").[B65000].End(3).Row
    
    ReDim ArrayDates(Taille + 2)
    ReDim ArrayValround(Taille + 2)
    ReDim ArrayClient(Taille + 2)
    ReDim ArrayFourn(Taille + 2)
    
    ReDim ArrayClientFinal(Taille + 2)
    ReDim ArrayFournFinal(Taille + 2)
    
    For i = 3 To Taille
        ArrayDates(i - 2) = Year(Sheets("Mvts Stock").Range("B" & i))
        ArrayValround(i - 2) = Round(Sheets("Mvts Stock").Range("V" & i), 2)
        ArrayClient(i - 2) = Sheets("Mvts Stock").Range("G" & i)
        ArrayFourn(i - 2) = Sheets("Mvts Stock").Range("F" & i)
    
        ArrayClientFinal(i - 2) = tFinal(i - 2, 1)
        ArrayFournFinal(i - 2) = tFinal(i - 2, 11)
    
    Next i
    For i = 1 To UBound(tFinal)
        For j = 1 To UBound(tMvtStock)
            Valround = ArrayValround(j)
            If ArrayClientFinal(i) = ArrayClient(j) And ArrayFournFinal(i) = ArrayFourn(j) Then Val1 = 1 Else Val1 = 0
            NoYear = ArrayDates(j)
            If Val1 = 1 Then
                Select Case NoYear
                    Case an1
                        somme = somme + Valround
                    Case an2
                        somme2 = somme2 + Valround
                    Case an3
                        somme3 = somme3 + Valround
                    Case an4
                        somme4 = somme4 + Valround
                    Case an5
                        somme5 = somme5 + Valround
                End Select
            End If
        Next j
        tFinal(i, 12) = somme
        tFinal(i, 13) = somme2
        tFinal(i, 14) = somme3
        tFinal(i, 15) = somme4
        tFinal(i, 16) = somme5
        somme = 0
        somme2 = 0
        somme3 = 0
        somme4 = 0
        somme5 = 0
    Next i
End If

fFourn.Range("B5").Resize(n - 1, 16) = tFinal

'Mise en forme de la cellule L5
    Range("L6").Copy
        Range("L5").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

Set fFourn = Nothing
Set fClients = Nothing
Set tabfin = Nothing
Set fMvtStock = Nothing
Set fVentes = Nothing
Set dcli = Nothing
Set dfourn = Nothing

MsgBox "Durée du traitement: " & Timer - start & " secondes"


    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With


End Sub

ET DU COUP :
Je suis passé de 100 secondes sur mon fichier original à à peine 15 secondes !!
Ça tient presque du miracle !!

Merci
A+

 

[sylvanu]

Bonjour,
Travailler dans un array est 10 fois plus rapide que de travailler dans des cellules.
Mais le remplacement des IF par des Cases accélére aussi car cela réduit drastiquement le nombre de calculs.

 

[job75]

Bonjour à tous,

Mais le remplacement des IF par des Cases accélére aussi car cela réduit drastiquement le nombre de calculs.

Chez moi je n'observe rien de tel :

Sub AvecIf()
Dim t, i&, n As Byte
t = Timer
For i = 1 To 100000000
    If n Then
        n = 1 - n
    Else
        n = 1 - n
    End If
Next
MsgBox Timer - t, , "Avec If"
End Sub

Sub AvecCase()
Dim t, i&, n As Byte
t = Timer
For i = 1 To 100000000
    Select Case n
        Case 0: n = 1 - n
        Case 1: n = 1 - n
    End Select
Next
MsgBox Timer - t, , "Avec Case"
End Sub

A+

 

[patricktoulon]

bonjour
tu pourrais peut être gagner du temps en créant et alimentant les tableaux a et b dans les boucles dico avec le test dico.exists(....) directement avec redim preserve ça éliminerait 2 boucles
'Dico pour les clients
For i = 1 To UBound(tMvtStock)
For j = 1 To UBound(tClients)

If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
And Year(tMvtStock(i, 1)) >= Annee Then
dcli(tMvtStock(i, 6)) = tMvtStock(i, 6)
End If
Next j
Next i

'Dico pour les fournisseurs
For i = 1 To UBound(tMvtStock)
For j = 1 To UBound(tClients)

If tMvtStock(i, 6) = tClients(j, 1) And tClients(j, 15) = "" _
And Year(tMvtStock(i, 1)) >= Annee Then
dfourn(tMvtStock(i, 5)) = tMvtStock(i, 5)
End If
Next j
Next i

ci dessous a ramener dans les boucles dico
ReDim a(1 To UBound(tMvtStock), 1 To 6)
n = 1
For Each c In dcli.keys
'Debug.Print d.Count
'Debug.Print d(c)
a(n, 1) = c
n = n + 1
Next c

ReDim b(1 To UBound(tMvtStock), 1 To 6)
m = 1
For Each c In dfourn.keys
'Debug.Print d.Count
'Debug.Print d(c)
b(m, 1) = c
m = m + 1
Next c

 

[sylvanu]

Bonjour le fil,
Job je n'ai pas dit qu'un Case s'effectuait plus vite qu'un IF.
J'ai dit que le nombre de calculs étaient différents.
Calvus a 4835 lignes à analyser, sur 5 années.
Avec des IF on a 24175 lignes à exécuter. ( car on passe par les 5 IF chaque fois )
Avec des Cases sachant qu'une fois l'année trouvée, on sort. On n'a que 17911 lignes à exécuter. Soit un gain de 26%.
Ce n'est pas les instructions mais la structure qui permet de gagner du temps.

 

[patricktoulon]

re
j'ajouterais que tu pédale dan la choucroute
tu crée un dictionnaire qui va certainement être moins long que la plage de base vu que les doublons et conditionels bye bye !!

ensuite avec ce même dico dans une double boucle sur le ubound de la plage.value tu alimente un tableau(a) dimensionné a la plage.value de départ
c'est absolument incohérent car arriver un un certain moment ton tableau a et ou b aura des lignes vides

alors oui tes if ou select cases (sylvanu) font leur boulot dans les boucles de traitement suivant mais les boucles pourrait s’arrêter bien bien bien bien ... avant !!!!

en l’état tel quel ;essai de mettre les To de tes boucle if au dico.count
puisque que par exemple dcli.count sensément DEVRAIT !!!!! être égal a ubound(a)
a méditer

 

[Calvus]

Bonjour à tous,

@patricktoulon

J'ai remplacé le code :

ReDim a(1 To UBound(tMvtStock), 1 To 6)
n = 1
For Each c In dcli.keys
    a(n, 1) = c
    n = n + 1
Next c

ReDim b(1 To UBound(tMvtStock), 1 To 6)
m = 1
For Each c In dfourn.keys
    b(m, 1) = c
    m = m + 1
Next c

Par :

ReDim a(1 To dcli.Count, 1 To 6)
n = 1
For Each c In dcli.keys
    a(n, 1) = c
    n = n + 1
Next c

ReDim b(1 To dfourn.Count, 1 To 6)
m = 1
For Each c In dfourn.keys
    b(m, 1) = c
    m = m + 1
Next c

C'est plus logique en effet, mais aucun gain de temps.

Par contre, pour ton post25, je n'ai pas saisi où tu voulais en venir.
Peux tu éclaircir ?

Merci

 

[patricktoulon]

re c'est bien mais il faut faire pareil pour les autres boucles aussi

et puis comme je te l'ai dis tu peux alimenter A et b directement dans leur boucle dico respectives
tu supprime ainsi 2 boucles de x milles lignes
et entre nous j'ai un peu peur dans tes if que les correspondances index de tableau ne soit pas cohérentes mais c'est trop le foutoir dans le code je ne m'y suis pas mis sérieusement

auserais je te dire que beaucoup d'omission
par exemple ici on sait pas sur quel sheets tu travaille

'Effacement du 1er tableau
For i = Range("B" & Rows.Count).End(xlUp).Row - 4 To 1 Step -1
    With tabfin
        .ListRows(i).Range.Delete
    End With
Next i

la boucle est basé sur quel sheets ? on sait pas
n'y a til pas moyen de deleter le tabfin en un seul coup cherche bien
un truc du genre par exemple
tabfin .DataBodyRange.Delete

et plein plein de petite chose comme ça qui te ferait gagner du temps

 

[Calvus]

Re,

n'y a til pas moyen de deleter le tabfin en un seul coup cherche bien

Si, cela a été fait, et pas mis à jour dans cette page.
ActiveSheet.ListObjects("Tableau13").DataBodyRange.Delete

C'est plus logique en effet, mais aucun gain de temps.

Pas de gain de temps en effet car cette partie de code ne sert à rien !!