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.

 

[sylvanu]

Bonjour Calvus,
Votre fichier ne semble pas être anonyme. ( Nom, Prénom, Tel,email ... )
Si c'est le cas, supprimez le et mettez l'équivalent avec des données bidon.

 

[Calvus]

Bonjour,

Ce sont déjà des données bidon..

A+

 

[sylvanu]

Sorry
Chez moi 106 secondes. C'est long !

 

[Calvus]

Pas de problème, je suis un habitué du forum depuis longtemps, ce genre de chose ne constitue plus de problème

 

[Staple1600]

Bonsoir le fil, Calvus(), sylvanu

Calvus
Ton code contient beaucoup de lignes?
Ou assez peu pour être posté dans le corps d'un post ?

 

[Calvus]

Hello mon ami !

Le voici :

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


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
    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
    For i = 1 To UBound(tFinal)
        For j = 1 To UBound(tMvtStock)
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
            And Year(tMvtStock(j, 1)) = an1 Then
                somme = somme + Round(tMvtStock(j, 21), 2)
            End If
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
            And Year(tMvtStock(j, 1)) = an2 Then
                somme2 = somme2 + Round(tMvtStock(j, 21), 2)
            End If
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
            And Year(tMvtStock(j, 1)) = an3 Then
                somme3 = somme3 + Round(tMvtStock(j, 21), 2)
            End If
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
            And Year(tMvtStock(j, 1)) = an4 Then
                somme4 = somme4 + Round(tMvtStock(j, 21), 2)
            End If
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) _
            And Year(tMvtStock(j, 1)) = an5 Then
                somme5 = somme5 + Round(tMvtStock(j, 21), 2)
            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

 

[sylvanu]

En optimisant l'écriture on descend à 68 s:

    Dim somme As Double, somme2 As Double, somme3 As Double, somme4 As Double, somme5 As Double
    Dim Val1 As Long, Val2 As Long
    For i = 1 To UBound(tFinal)
        For j = 1 To UBound(tMvtStock)
            Valround = Round(tMvtStock(j, 21), 2)
            If tFinal(i, 1) = tMvtStock(j, 6) And tFinal(i, 11) = tMvtStock(j, 5) Then Val1 = 1 Else Val1 = 0
            If Val1 = 1 And Year(tMvtStock(j, 1)) = an1 Then somme = somme + Valround
            If Val1 = 1 And Year(tMvtStock(j, 1)) = an2 Then somme2 = somme2 + Valround
            If Val1 = 1 And Year(tMvtStock(j, 1)) = an3 Then somme3 = somme3 + Valround
            If Val1 = 1 And Year(tMvtStock(j, 1)) = an4 Then somme4 = somme4 + Valround
            If Val1 = 1 And Year(tMvtStock(j, 1)) = an5 Then somme5 = somme5 + Valround
        Next j
        tFinal(i, 12) = somme
        tFinal(i, 13) = somme2
        tFinal(i, 14) = somme3
        tFinal(i, 15) = somme4
        tFinal(i, 16) = somme5

Evidemment c'est encore trop long. Donc il faut absolument passer par des arrays.

 

[Calvus]

Re,

Effectivement, c'est passé à 60 secondes chez moi.
Merci !

Evidemment c'est encore trop long. Donc il faut absolument passer par des arrays.

Peux tu m'indiquer la piste à suivre ?

 

[sylvanu]

Je suis entrain de regardez.
Il faut passer la colonne B an array, ça va grandement améliorer les choses.
( entre un accès cellule et un accès array il y a un rapport 10 sur le temps d'accès )

 

[Staple1600]

Re

Merci
Pourquoi cette boucle?

'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^

Une ligne suffit

Sub testA()
'supprime le contenu
ActiveSheet.ListObjects("loTest").DataBodyRange.Rows.ClearContents
End Sub

ou

Sub testB()
'supprime les lignes sauf la première et la ligne d'entete
ActiveSheet.ListObjects("loTest").DataBodyRange.Delete
End Sub

 

[Calvus]

Re,

Merci Staple.

Pourquoi cette boucel?

Pourquoi ? Parce que je ne savais pas !

 

[Staple1600]

Re

Tu as testé les deux macros de mon précédent post ?
(en changeant le nom du tableau dans le code évidemment )

 

[Calvus]

Re,

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

 

[sylvanu]

Bonjour tout le monde,
Je suis tombé à 11s :
- Basculer les colonnes an arrays
- Transformer les valeurs arrays en valeurs utiles
- Supprimer les IF et les remplacer par des Case.

Je continue.