Optimisation de code VBA - lenteur macro Résolu/Fermé

Question

Bonjour à tous,
Je débute dans l'utilisation des macros et je me suis lancée dans un projet assez ambitieux.
La macro a pour objectif de retrouver des données sur différentes tables assez volumineuses (entre 5.000 et 100.000 lignes), et de les rapatrier sur la feuille récap nommée INTEG.
Le nombre de lignes sur lesquelles les recherches sont effectuées sont très importantes (min 50.000 lignes).
La macro fonctionne cependant elle est d'une extrême lenteur (plus de 10 min pour une centaine de lignes sur les derniers tests).
Sauriez-vous comment réduire ce temps ? Je pense que c'est en partie à cause de la construction de la macro (ex de code ci-dessous, pour une table)

Sub RechTABCAts()

Sheets("INTEG").Select

Dim Nbdedonnees As Long
Nbdedonnees = Application.WorksheetFunction.CountA(Range("N:N"))

Dim NbElements As Long
NbElements = Application.WorksheetFunction.CountA(Range("B:B")) - Nbdedonnees

Dim NbTabCAts2 As Long
NbTabCAts2 = Application.WorksheetFunction.CountA(Sheets("TAB CAts2").Range("A:A"))

Dim NbTabCAts As Long
NbTabCAts = Application.WorksheetFunction.CountA(Sheets("TAB CAts").Range("A:A"))

Dim CompteurValCAts As Integer
CompteurValCAts = 0

For x = 1 To NbElements

Cells(Nbdedonnees + x, 21).Value = Left(Cells(Nbdedonnees + x, 4), 6)

' Recherche Tab CAts
    For g = 1 To NbTabCAts2
        If Cells(Nbdedonnees + x, 21).Value = Sheets("TAB CAts2").Cells(g, 1).Value Then
                Cells(Nbdedonnees + x, 14).Value = Sheets("TAB CAts2").Cells(g, 4).Value
                Cells(Nbdedonnees + x, 15).Value = Sheets("TAB CAts2").Cells(g, 5).Value
                Cells(Nbdedonnees + x, 16).Value = Sheets("TAB CAts2").Cells(g, 6).Value
                Cells(Nbdedonnees + x, 17).Value = Sheets("TAB CAts2").Cells(g, 7).Value
                Cells(Nbdedonnees + x, 18).Value = Sheets("TAB CAts2").Cells(g, 8).Value
                CompteurValCAts = CompteurValCAts + 1
                GoTo FinTabCAts
        End If
    Next g
        
    If CompteurValCAts < 1 Then
        For f = 1 To NbTabCAts
            If Cells(Nbdedonnees + x, 4).Value = Sheets("TAB CAts").Cells(f, 1).Value Then
                    Cells(Nbdedonnees + x, 14).Value = Sheets("TAB CAts").Cells(f, 2).Value
                    Cells(Nbdedonnees + x, 15).Value = Sheets("TAB CAts").Cells(f, 3).Value
                    Cells(Nbdedonnees + x, 16).Value = Sheets("TAB CAts").Cells(f, 4).Value
                    Cells(Nbdedonnees + x, 17).Value = Sheets("TAB CAts").Cells(f, 5).Value
                    Cells(Nbdedonnees + x, 18).Value = Sheets("TAB CAts").Cells(f, 6).Value
                    CompteurValCAts = CompteurValCAts + 1
                    GoTo FinTabCAts
            End If
        Next f
    End If
     
    If CompteurValCAts < 1 Then
        Cells(Nbdedonnees + x, 14).Value = "ND TAB CAts"
        Cells(Nbdedonnees + x, 15).Value = "ND TAB CAts"
        Cells(Nbdedonnees + x, 16).Value = "ND TAB CAts"
        Cells(Nbdedonnees + x, 17).Value = "ND TAB CAts"
        Cells(Nbdedonnees + x, 18).Value = "ND TAB CAts"
    End If
    
FinTabCAts:

Next x

Construction des feuilles :
INTEG :


TAB CAts:


TAB CAts2:


Merci d'avance pour votre aide / suggestions !

j.pierrot · Answer

Je précise que le but de ce code est de faire les recherches sur une première table, puis sur une seconde en cas d'échec, puis de renvoyer un message en cas d'absence de correspondance dans les deux tables.

Heas · Answer

Bonjour,
un projet ambitieux de mon point de vue.

Quelques questions pour essayer d'expliquer ces temps de réponse :

Quel est votre OS?
Quelle est la version d'excel?
Quelle est la taille  de la mémoire vive?
Quelle est la taille du fichier Swap?

Car à première vue, il  me semble que le PC ne pourra pas traiter ce problème dans la mémoire centrale, de ce fait, le PC va décharger et charger continuellement des informations depuis la mémoire centrale vers le disque dur.

Dernière question donc, le disque semble travailler beaucoup pendant l'exécution?

Bon courage!

Le Pingou · Answer

Bonjour,
Au passage, je suppose que les données sont dans le même classeur   Oui / Non 
Je pense que les boucles pour récupérer les données prennent du temps. Préférable de le faire par variable tableau .... !

Le Pingou · Answer

Bonjour,
Peut-être sur l'excellent site de Boisgontier (Salutations) par ici.
 
 
Salutations.
Le Pingou

michel_m · Answer

Bonjour,

Il est très difficile de comprendre ton code et ce que tu veux faire !
il est nécessaire d'expliquer en termes clairs sans rien oublier le but de ton traitement

AU besoin
mettre un extrait du  classeur (2000 lignes environ) sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci  proposé (clic droit) dans le message de réponse
Dans l'attente

Heas · Answer

Bonjour,
la remarque sur le bruit d'avion laisse penser qu'effectivement il y a échange entre le disque dur et la mémoire centrale(swap).

Ceci mis à part, j'ai vu dans la version de macro citée dans l'appel un "GO TO".

Et ce "Go TO" est situé dans une boucle avec 
    For G
    Next G
Déja, au niveau programmation, c'est à éviter.

SANS PRETENDRE RESOUDRE LE PROBLEME, deux remarques sur la macro existante :
1)Une première boucle basée sur NbElements (valeur de NBElements?)
Une deuxième boucle basée sur NbTabCAts2 (Valeur de NbTabCAts2?)
Le temps de travail est basé sur la multiplication de NbTabCAts2 par NBElements. A EVITER SI POSSIBLE.

2) Une structure IF End IF existe.
Quand la condition est remplie, "CompteurValCAts = CompteurValCAts + 1"
Alors une suggestion, supprimer le "GoTo FinTabCAts" et remplacer par 
   "g =  NbTabCAts2 +1"
Ainsi, on sort de la boucle for G    Next G
   Et comme CompteurValCAts est à 1, les deux blocs suivants ne sont pas exécutés. Certes cela fait deux contrôles supplémentaires, mais mieux que le go to dans une boucle.

Sur ces quelques conseils, en notant que votre macro a déja le mérite d'être claire en écriture, je vais essayer de reprendre le problème à la base.

Si j'arrive à comprendre ce que vous voulez faire, je vous conseillerai éventuellement de reprendre le problème à la base. Ce qui arrive aussi aux informaticiens, rassurez-vous.

Bon courage

j.pierrot · Answer

J'ai tenté de modifier le code en prenant en compte les remarques d'Heas ainsi que le passage par une variable tableau comme conseiller par Le Pingou.

Cependant, le fait de définir le tableau par rapport à une variable est bloquant et la macro ne fonctionne donc pas. Le tableau doit-il obligatoirement être défini par des limites fixes ? Ou me suis-je trompée de formulation ?

Sub RechTABCAts()

Sheets("INTEG").Select

Dim Nbdedonnees As Long
Nbdedonnees = Application.WorksheetFunction.CountA(Range("N:N"))

Dim NbElements As Long
NbElements = Application.WorksheetFunction.CountA(Range("B:B")) - Nbdedonnees

Dim NbTabCAts2 As Long
NbTabCAts2 = Application.WorksheetFunction.CountA(Sheets("TAB CAts2").Range("A:A"))

Dim NbTabCAts As Long
NbTabCAts = Application.WorksheetFunction.CountA(Sheets("TAB CAts").Range("A:A"))

Dim NbNDTABCAts As Long
NbNDTABCAts = 0

Dim CompteurValCAts As Integer
CompteurValCAts = 0

Dim RechCAts(1 To NbElements, 6)
For x = 1 To NbElements

RechCAts(x, 1) = Left(Cells(Nbdedonnees + x, 4), 6) 'Récupération des 6 premiers caractères du code comptable

' Recherche dans TAB CAts2 par rapport au 6 premiers caractères
    For g = 1 To NbTabCAts2
        If RechCAts(x, 1) = Sheets("TAB CAts2").Cells(g, 1).Value Then 'si correspondance avec la table trouvée, récupérer les données
                RechCAts(x, 2) = Sheets("TAB CAts2").Cells(g, 4).Value
                RechCAts(x, 3) = Sheets("TAB CAts2").Cells(g, 5).Value
                RechCAts(x, 4) = Sheets("TAB CAts2").Cells(g, 6).Value
                RechCAts(x, 5) = Sheets("TAB CAts2").Cells(g, 7).Value
                RechCAts(x, 6) = Sheets("TAB CAts2").Cells(g, 8).Value
                CompteurValCAts = CompteurValCAts + 1
                g = NbTabCAts2 + 1 'si valeur trouvée, sortir de la boucle
        End If
    Next g
    
   'Sinon, rechercher les donner dans la table TAB CAts
        If CompteurValCAts = 0 Then
            For f = 1 To NbTabCAts
                If Cells(Nbdedonnees + x, 4).Value = Sheets("TAB CAts").Cells(f, 1).Value Then
                    RechCAts(x, 2) = Sheets("TAB CAts").Cells(f, 2).Value
                    RechCAts(x, 3) = Sheets("TAB CAts").Cells(f, 3).Value
                    RechCAts(x, 4) = Sheets("TAB CAts").Cells(f, 4).Value
                    RechCAts(x, 5) = Sheets("TAB CAts").Cells(f, 5).Value
                    RechCAts(x, 6) = Sheets("TAB CAts").Cells(f, 6).Value
                    CompteurValCAts = CompteurValCAts + 1
                    g = NbTabCAts2 + 1 'si valeur trouvée, passer à la ligne suivante
                End If
            Next f
        End If
        
        If CompteurValCAts = 0 Then ' SInon indiquer qu'il n'y a pas de correspondance et renvoyer le nombre de lignes sans correspondance dans une msgbox
            RechCAts(x, 2) = "ND TAB CAts"
            RechCAts(x, 3) = "ND TAB CAts"
            RechCAts(x, 4) = "ND TAB CAts"
            RechCAts(x, 5) = "ND TAB CAts"
            RechCAts(x, 6) = "ND TAB CAts"
            NbNDTABCAts = NbNDTABCAts + 1
        End If

Next x

For x = 1 To NbElements 'récupération des données  de RechCAts dans les cellules de la feuille Integ
    Cells(Nbdedonnees + x, 14).Value = RechFrs(x, 2)
    Cells(Nbdedonnees + x, 15).Value = RechFrs(x, 3)
    Cells(Nbdedonnees + x, 16).Value = RechFrs(x, 4)
    Cells(Nbdedonnees + x, 17).Value = RechFrs(x, 5)
    Cells(Nbdedonnees + x, 18).Value = RechFrs(x, 6)
Next x

Erase RechFrs

MsgBox ("Recherches n'ayant pas aboutit : " & NbNDTABCAts)

End Sub

j.pierrot · Answer

Quelques erreur dans le code ci-dessus à partir de la dernière boucle :
For x = 1 To NbElements 'récupération des données  de RechCAts dans les cellules de la feuille Integ
    Cells(Nbdedonnees + x, 14).Value = RechCAts(x, 2)
    Cells(Nbdedonnees + x, 15).Value = RechCAts(x, 3)
    Cells(Nbdedonnees + x, 16).Value = RechCAts(x, 4)
    Cells(Nbdedonnees + x, 17).Value = RechCAts(x, 5)
    Cells(Nbdedonnees + x, 18).Value = RechCAts(x, 6)
Next x

Erase RechCAts

Rq : En définissant le tableau avec un nombre fixe, la macro fonctionne bien.

Le Pingou · Answer

Bonjour j.pierrot,
Merci pour le fichier. 
Je vais regarder ce qui est faisable par rapport à votre procédure, il est possible que michel_m sera plus rapide... !

michel_m · Answer

re, 
je n'ai pas trouvé la définition de Rechfrs... 

ci dessous début de la macro en tentant de montrer l'utilisation  des variables -tableaux. Normalement, tu devrais pouvoir continuer sans moi mais tu dis si...;o)
Option Base 1'---------------------------------Sub rechercher()Dim Derlig As Long, NbElements As Long, T_integ   'sh integDim T_cats 'sh tab catsDim T_cast2 'sh tab cats2Dim Cptr As Long, Lig As Long, Col As Byte, CompteurValCAts As Long'---------------------Initialisations    Application.ScreenUpdating = False    'mémorisation RAm données    With Sheets("integ")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        T_integ = .Range("A2:R" & Derlig)    End With   With Sheets("TAB CAts")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        T_cats = .Range("A2:E" & Derlig)    End With    With Sheets("TAB CAts2")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        T_cats2 = .Range("A2:H" & Derlig)    End With'------------------------------traitement des données    For Cptr = 1 To UBound(T_integ)        'Récupération des 6 premiers caractères du code comptable        T_cats(Cptr, 1) = Left(T_integ(Cptr, 4), 6)        For Lig = 1 To UBound(T_cast2)            'si correspondance avec la table trouvée, récupérer les données            If T_cats(Cptr, 1) = T_cats2(Lig, 1) Then               For Col = 2 To 6                    T_cats(Cptr, Col) = T_cast2(Lig, Col + 2)                Next Col                Exit For            End If            ''Sinon, rechercher les donner dans la table TAB CAts            If CompteurValCAts = 0 Then            '......... à toi de jouer       Next For    Next Lig    '........End Sub

 Pour apprende les variables tableaux à mon avis le + complet
https://silkyroad.developpez.com/vba/tableaux/

 Michel

Heas · Answer

Bonsoir,
quelques précisions : Je suis sur ce forum depuis peu, j'avais lancé un appel à l'aide et reçu de très bons conseils.

Aussi en retour j'essaie de donner des conseils(quand je peux...)

Je viens d'essayer d'ouvrir le fichier défini plus haut. Mais je n'ai pas Excel, je travaille avec Open Office.
Est-il possible de définir avec quel logiciel l'ouvrir dans la procédure ?

Sinon, il est possible de me le transférer sur une adresse mail.
Car j'aimerais bien comprendre ce qu'il faut modifier comme code.
Après, peut-être ai-je une chance de trouver une solution.

michel_m · Answer

Bonjour J pierrot

dans ce que je t'ai proposé je n'ai pas traité la restitution des variables -tableaux entre autres car il y a des fonctionnalités que je n'ai pas compris et/ou parues bizarres 
donc, n'hésite pas

cordialement

A l'attention de Monsieur Heas:
Bonjour
..."Sinon, il est possible de me le transférer sur une adresse mail.'...

Pourquoi?
L'intérêt et le but des forums d'entraide est le partage des connaissances: un fichier Excel est lisible sous Open Office mais la syntaxe des macros est différente.
Sauf clause de confidentialité extrême il est déconseillé d'employer les messages privés pour des questions techniques.
 
 Michel

Heas · Answer

Bonjour,
j'ai pu ouvrir le fichier OpenOffice.

Quelques questions, sachant que je m'intéresse à la macro décrite lors de l'appel Sub RechTABSU() :
1) Dim Nbdedonnees As Long
Nbdedonnees = Application.WorksheetFunction.CountA(Range("I:I"))

La colonne I est vide, c'est dû au classeur en ma possession? Sinon quelle est la VALEUR MAXIMUM de Nbdedonnees ?

2) Dim RechSU(1 To 100000, 5) 'variable tableau pour les calculs
Dimensionner une matrice de 500 000 valeurs est une charge lourde pour la machine.
D'autant que le but de la première phase de recherche 
      x = 1 To NbElements est de trouver des informations. Il n'est pas utile de les copier physiquement à ce moment-là.

Il suffit de déclarer un tableau de 100 000 valeurs DECIMALES(en attendant une analyse plus approfondie du problème général), de mémoriser la valeur de l'index b.

Dans la deuxième boucle x = 1 To NbElements, on va utiliser la valeur d'index mémorisée dans le tableau pour faire la copie de Sheets("TAB SU")   vers la feuille integ

Ce qui évite de mémoriser les valeurs dans le tableau, avant de les copier. L'information existe deux fois, et non trois fois.

3) QUELLE EST LA VALEUR MAXIMUM  de  NbTabSU ?
Il est évident que si NbElements et NbTabSU  sont importants, le temps d'exécution dépend de la multiplication de NbElements par NbTabSU

Une solution pour éviter un parcours complet de NbTabsu, la recherche dichotomique après avoir trié Tab_SU

Le principe, si on a une recherche à faire sur une table des 10 000 valeurs :

FlagRecherche = 0
BorneBasse=1
Borne Haute= 10 000
Moyenne =PartieENtiere de (BorneBasse+BorneHaute)/2

Tant que : FlagRecherche =0 
     Si ValeurRecherchee =  Valeur fonction de Moyenne
 Alors   FlagRecherche=1
Sinon / Si ValeurRecherchee < Valeur fonction de Moyenne
              Alors BorneHaute = Moyenne
              sinon BorneBasse = Moyenne
         Moyenne=  PartieENtiere de (BorneBasse+BorneHaute)/2
Répéter

Cette méthode permet d'identifier en 40 boucles une valeur dans une table de 10 000 valeurs (2E4= 10   2E10=1024)


Voila quelques commentaires à chaud sur l'existant.
Il n'est pas sûr que cela résolve tout, je vais y travailler d'un peu plus près


Cordialement

michel_m · Answer

Bonjour

ci dessous proposition de code
Option ExplicitOption Base 1'---------------------------------'le but de ce code est de faire les recherches sur une première table, _puis sur une seconde en cas d'échec, _puis de renvoyer un message en cas d'absence de correspondance dans les deux tables'-----------------------------------------------------------------------------------------------Sub rechercher()Dim Derlig As Long, Ligvid As Long, T_integ, T_calcul  'sh integDim T_cats, D_cats As Object 'sh tab catsDim T_cast2, D_cast2 As Object 'sh tab cats2Dim Cptr As Long, Coda As String, Lig As Long, Col As Byte 'traitementDim NbNDTABCAts As Long 'traitementDim Start As Single 'test durée d'execution'-------------------------------initialisation    Start = Timer    Application.ScreenUpdating = False    'mémorisation RAm données    With Sheets("integ")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        Ligvid = .Columns("N").Find(what:="", after:=.Range("N1")).Row        T_integ = .Range(.Cells(Ligvid, "A"), .Cells(Derlig, "U"))        ReDim T_calcul(Derlig - Ligvid+1, 5)    End With   With Sheets("TAB CAts")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        T_cats = .Range("A2:E" & Derlig)        'liste des coda et ligne de position(cptr)        Set D_cats = CreateObject("scripting.dictionary")        For Cptr = 1 To UBound(T_cats)            If Not D_cats.exists(T_cats(Cptr, 1)) Then: D_cats.Add T_cats(Cptr, 1), Cptr        Next    End With    With Sheets("TAB CAts2")        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row        T_cast2 = .Range("A2:H" & Derlig)        Set D_cast2 = CreateObject("scripting.dictionary")        For Cptr = 1 To UBound(T_cast2)            If Not D_cast2.exists(T_cast2(Cptr, 1)) Then: D_cast2.Add T_cast2(Cptr, 1), Cptr        Next    End With'------------------------------traitement des données    For Cptr = 1 To UBound(T_integ)        Coda = Left(T_integ(Cptr, 4), 6)        If D_cast2.exists(Coda) Then            Lig = D_cast2.Item(Coda)            For Col = 4 To 8                    T_calcul(Cptr, Col - 3) = T_cast2(Lig, Col)            Next Col        Else            Coda = T_integ(Cptr, 4)            If D_cats.exists(Coda) Then                Lig = D_cats.Item(Coda)                For Col = 2 To 6                    T_calcul(Cptr, Col - 1) = T_cats(Lig, Col)                Next Col            Else                For Col = 1 To 4                    T_calcul(Cptr, Col) = "ND TAB CATS"                Next Col                NbNDTABCAts = NbNDTABCAts + 1            End If        End If    Next    '---------------------------------restitution    With Sheets("integ")        .Range("N" & Ligvid).Resize(UBound(T_calcul), 4) = T_calcul    End With    Application.ScreenUpdating = True    MsgBox ("Recherches n'ayant pas abouti : " & NbNDTABCAts & vbLf & _                        "durée de traitement: " & Timer - Start & " secondes")End Sub 
 
Mais j'ai eu des trucs bizarres et des aberrations avec l'éditeur de codes VBA ( comptage des NbNDTABCAts, nombre de lignes de T_calcul  par ex) 
Tu dis si ca te fait pareil, je regarderais alors à t^te reposée

Edit 10:44h 
modifié en tebant compte de ligvid:
ReDim T_calcul

Michel

Heas · Answer

Bonjour,
je viens de tenter un manip toute simple sur un PC récent (intelCore i5-4590   3.3 gHz  mémoire 4Go) :

Dans une grille OpenOffice, création de 105000 valeurs en ligne 1 , colonne 1

Insertion d'une ligne en L1

Temps de réponse 5mn.
Je ne sais pas comment cela se passe avec Excel, mais je suppose que c'est la même chose.

Est-ce que vous pourriez tenter la manip (michel_m et j.pierrot)

Merci

Optimisation de code VBA - lenteur macro

15 réponses

Discussions similaires