Microsoft 365 Accelerer l'execution du code

[Faroyo]

Bonjour,
plutot debutant en vba, je cheche un moyen d'accelerer l'execution de mon code.
J'ai une boucle index match combinée avec un 2 vlookup. Tout fonctionne tres bien mais il peut prendre pas mal de temps.
La recheche s'effectue dans une base de pouvant contenir 100000 lignes d'ou le pb, enfin je pense.
Merci pour votre aide.

Faroyo

 Sub Newold()

Dim lastline As Integer

Dim ws1 As Worksheet: Set ws1 = Sheets("MARC_POSTLOAD_1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Conversion New - Old")
Dim vBase, C As Range

Application.ScreenUpdating = False
Application.EnableEvents = False

lastline = ws1.Range("A:A").End(xlDown).Row

   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Application.WorksheetFunction

If ws2.Range("A2") <> "" Then

    For x = 2 To lastline
    
        Range("B" & x).Value = (Application.Index(ws1.Range("A:B"), Application.Match(ws2.Range("A" & x), ws1.Range("B:B"), 0), 1))
        If IsError(Range("B" & x).Value) Then
        Range("B" & x).Value = ""
        End If
        Range("C" & x).Value = Application.WorksheetFunction.IfError(Application.VLookup(Range("A" & x).Value, ws1.Range("B:H"), 4, 0), "") 'Description
        Range("D" & x).Value = Application.WorksheetFunction.IfError(Application.VLookup(Range("A" & x).Value, ws1.Range("B:H"), 7, 0), "") 'Description

  Next
 
  End If
    
    End With

 format
 
End Sub

 

[sylvanu]

Bonjour Faroyo,
Donnez nous un petit fichier test représentatif, ce sera plus simple que de se le retaper.

 

[Efgé]

Bonjour @Faroyo , Salut @sylvanu
Je plussois à la demande de sylvanu, la question est pour le moins surprenante:

Dim lastline As Integer

Alors que:

base de pouvant contenir 100000 lignes

J'attend l'exemple avec impatience

D'autre part, une première remarque :
Si Application.ScreenUpdating = False n'a pas forcément besoin d'un Application.ScreenUpdating = True, il n'en vas pas de même pour Application.EnableEvents
Cordialement

 

[Faroyo]

Toutes mes exceuses pour ce contre temps. Gros pb de connexion suite a l'installation de la fibre.
Le pb semble résolut à présent, pour le réseau mais pas pour mon fichier.
Merci pour la remarque concernant Application.EnableEvents
Je vous joins le fichier. J'ai reduit le fichier à 10000 lignes afin de pouvoir le déposer.
Mon soucis de lenteur est avec l'onglet "Conversion New - Old". Il s'agit là, de convertir les valeurs en bleu dans l'onglet "data" pour retrouver les valeurs en vert du meme onglet. Menme avec que 10000 lignes la recherche est tres lente. Avec la totalité dess donnees c'est juste pas possible.

Merci pour votre aide

 

[sylvanu]

Bonjour Faroyo, Efgé,
Une possibilité, plutôt qu'on long for next, est de mettre les formules dans la feuille puis de faire un copier coller des valeurs.
Sur mon PC on passe de 22s à 5s. Avec pour les formules dans Newold :

If ws2.Range("A2") <> "" Then
    Range("B2:B" & lastline) = _
        "=IFERROR(INDEX(data!C[-1]:C,MATCH(RC[-1],data!C,0),1),"""")"   'B2 : =SIERREUR(INDEX(data!A:B;EQUIV(A2;data!B:B;0);1);"")
    Range("C2:C" & lastline) = _
        "=IfError(VLookup(RC[-2], data!C[-1]:C[5], 4, false), """")"    'C2 : =SIERREUR(RECHERCHEV(A2; data!B:H; 4; FAUX); "")
    Range("D2:D" & lastline) = _
        "=IFERROR(VLOOKUP(RC[-3],data!C[-3]:C[4],7,FALSE),"""")"        'D2 : =SIERREUR(RECHERCHEV(A2;data!A:H;7;FAUX);"")
    Range("B2:DZ" & lastline) = Range("B2:DZ" & lastline).Value         ' Copier Coller valeurs
End If

J'ai rappelé en commentaires les formules utilisées au cas où elles seraient erronées pour pouvoir rectifier.

 

[Faroyo]

Bonjour Faroyo, Efgé,
Une possibilité, plutôt qu'on long for next, est de mettre les formules dans la feuille puis de faire un copier coller.
Sur mon PC on passe de 22s à 5s. Avec pour les formules dans Newold :

If ws2.Range("A2") <> "" Then
    Range("B2:B" & lastline) = _
        "=IFERROR(INDEX(data!C[-1]:C,MATCH(RC[-1],data!C,0),1),"""")"   'B2 : =SIERREUR(INDEX(data!A:B;EQUIV(A2;data!B:B;0);1);"")
    Range("C2:C" & lastline) = _
        "=IfError(VLookup(RC[-2], data!C[-1]:C[5], 4, false), """")"    'C2 : =SIERREUR(RECHERCHEV(A2; data!B:H; 4; FAUX); "")
    Range("D2:D" & lastline) = _
        "=IFERROR(VLOOKUP(RC[-3],data!C[-3]:C[4],7,FALSE),"""")"        'D2 : =SIERREUR(RECHERCHEV(A2;data!A:H;7;FAUX);"")
    Range("B2:DZ" & lastline) = Range("B2:DZ" & lastline).Value         ' Copier Coller valeurs
End If

J'ai rappelé en commentaires les formules utilisées au cas où elles seraient erronées pour pouvoir rectifier.

Merci
je vais de ce pas tester cette solution

 

[Faroyo]

Merci Efgé,

Ça fonctionne nettement mieux qu'avant. C'est juste ce qu'il me fallait.
Encore merci pour votre.
Je vous souhaite une bonne journée.

Faroyo

 

[sylvanu]

Impeccable.
Mettez la solution en vert et non votre message de bonne réception, ce sera plus lisible pour les futurs lecteurs.

 

[Faroyo]

C'est pas faux. Encore merci

 

[Faroyo]

Merci
je vais de ce pas tester cette solution

Bonjour Faroyo, Efgé,
Une possibilité, plutôt qu'on long for next, est de mettre les formules dans la feuille puis de faire un copier coller des valeurs.
Sur mon PC on passe de 22s à 5s. Avec pour les formules dans Newold :

If ws2.Range("A2") <> "" Then
    Range("B2:B" & lastline) = _
        "=IFERROR(INDEX(data!C[-1]:C,MATCH(RC[-1],data!C,0),1),"""")"   'B2 : =SIERREUR(INDEX(data!A:B;EQUIV(A2;data!B:B;0);1);"")
    Range("C2:C" & lastline) = _
        "=IfError(VLookup(RC[-2], data!C[-1]:C[5], 4, false), """")"    'C2 : =SIERREUR(RECHERCHEV(A2; data!B:H; 4; FAUX); "")
    Range("D2:D" & lastline) = _
        "=IFERROR(VLOOKUP(RC[-3],data!C[-3]:C[4],7,FALSE),"""")"        'D2 : =SIERREUR(RECHERCHEV(A2;data!A:H;7;FAUX);"")
    Range("B2:DZ" & lastline) = Range("B2:DZ" & lastline).Value         ' Copier Coller valeurs
End If

J'ai rappelé en commentaires les formules utilisées au cas où elles seraient erronées pour pouvoir rectifier.

Toutes mes excuses Sylvanu,,
je viens de me rendre compte que de je remerciais la mauvaise personne. J'ai un peu honte.
Je suis désolé.
Alors, mille merci Sylvanu

 

[eriiic]

Bonjour,

il y avait en plus une erreur de conception dans ton code.

lastline = ws1.Range("A:A").End(xlDown).Row
If ws2.Range("A2") <> "" Then
    For x = 2 To lastline
        Range("B" & x).Value = (Application.Index(ws1.Range("A:B"), Application.Match(ws2.Range("A" & x), ws1.Range("B:B"), 0), 1))

tu regardes le nombre de lignes de data pour écrire celles Conversion.
Ca t'en fait 10000 même si tu ne convertis que 2 ref.

D'autre part tu fais un Recherchev() sur data!$B$1:$H$10901.
Hors la colonne B n'est pas triée ce qui est obligatoire, si je ne m'abuse, pour une recherche exacte avec ;FAUX) ou ;0) comme tu as écrit
eric

 

[Faroyo]

Bonjour Eriiic,
très pertinente ta remarque sur le tri. C'est parfaitement exacte.
Je vais corriger cela.
Par contre , je ne comprends pas trop ta remarque sur la conception. Il faut que tu m'en dises plus à présent.

Merci

 

[eriiic]

Tu veux balayer les ligne de ws2 (tes saisies à rechercher, et tu comptes le nombre de lignes de ws1
Résultat, si tu as 2 recherches à faire, tu inscris tes formules sur 10000 lignes.
Forcément c'est plus long que nécessaire...

Dim ws1 As Worksheet: Set ws1 = Sheets("data") ' 10000 lignes
Dim ws2 As Worksheet: Set ws2 = Sheets("Conversion New - Old")

lastline = ws1.Range("A:A").End(xlDown).Row ' ws1 : 10000 lignes !!!!
If ws2.Range("A2") <> "" Then
    For x = 2 To lastline ' =to 10000
        Range("B" & x).Value = ' tu travailles sur la feuille active (ws2) qui n'a peut-être que 2 lignes à faire

C'est plus plus clair ?
Ce pb est sans aucun doute corrigé dans les propositions qui t'ont été faites.
C'était plus pour t'alerter d'être attentif à ce que tu écris, de tester au fur et à mesure, de contrôler tes valeurs de variables en pas à pas, bref d'apprendre à déboguer un minimum .
eric

 

[Faroyo]

Ok eriiic.
Tous conseils est bon à prendre et je prends tout.

Merci pour ces conseils.
bonne journee