Microsoft 365 Accelerer l'execution du code

Faroyo · 14 Mars 2022

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

VB:

 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 · 16 Mars 2022

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 :

VB:

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);"")...

sylvanu · 14 Mars 2022

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

Efgé · 14 Mars 2022

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

Faroyo à dit:
Dim lastline As Integer

Alors que:

Faroyo à dit:
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 · 16 Mars 2022

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 · 16 Mars 2022

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 :

VB:

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 · 16 Mars 2022

sylvanu à dit:
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 :

VB:

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 · 16 Mars 2022

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 · 16 Mars 2022

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

Faroyo · 16 Mars 2022

C'est pas faux. Encore merci
👍

Faroyo · 16 Mars 2022

Faroyo à dit:
Merci
je vais de ce pas tester cette solution

sylvanu à dit:
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 :

VB:

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 · 16 Mars 2022

Bonjour,

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

VB:

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 · 16 Mars 2022

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 · 16 Mars 2022

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

VB:

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 · 17 Mars 2022

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

Merci pour ces conseils.
bonne journee

Microsoft 365 Accelerer l'execution du code

Faroyo

XLDnaute Junior

sylvanu

sylvanu

XLDnaute Barbatruc

Efgé

XLDnaute Barbatruc

Faroyo

XLDnaute Junior

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Faroyo

XLDnaute Junior

Faroyo

XLDnaute Junior

sylvanu

XLDnaute Barbatruc

Faroyo

XLDnaute Junior

Faroyo

XLDnaute Junior

eriiic

XLDnaute Barbatruc

Faroyo

XLDnaute Junior

eriiic

XLDnaute Barbatruc

Faroyo

XLDnaute Junior

Discussions similaires

Microsoft 365 Accelerer l'execution du code

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Junior

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

Discussions similaires

Privacy & Transparency

Privacy & Transparency