Optimisation de code VBA - lenteur macro

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.

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!

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 .... !

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

Salutations.
Le Pingou

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

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

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.

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... !

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 integ
Dim T_cats 'sh tab cats
Dim T_cast2 'sh tab cats2
Dim 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

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.

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

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

Bonjour

ci dessous proposition de code

Option Explicit
Option 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 integ
Dim T_cats, D_cats As Object 'sh tab cats
Dim T_cast2, D_cast2 As Object 'sh tab cats2
Dim Cptr As Long, Coda As String, Lig As Long, Col As Byte 'traitement
Dim NbNDTABCAts As Long 'traitement
Dim 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

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