Double loop for trop lente

Version imprimable

Bonjour à tous,

J'ai dans un même fichier deux feuilles à mettre en relation pour ce faire j'ai voulu effectuer un vlookup en vba. Mon problème étant la lenteur d'exécution de ma macro je remonte de la feuille1 (~600lignes) deux colonnes dans la feuille2 (~14000).
J'ai essayé de coder de deux manière différente mais je reste toujours entre 3 & 4min d'exécution. Ci-dessous mes deux tentatives en m'en remettant à votre expertise et en vous remerciant par avance.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub vlookup()
Dim i As Long
Dim j As Long
LR1 = Worksheets("POr files").Range("E" & Rows.Count).End(xlUp).Row
LR2 = Worksheets("Doc Buy").Range("A" & Rows.Count).End(xlUp).Row
 
    For j = 7 To LR2
        For i = 2 To LR1
            If Worksheets("Doc Buy").Range("A" & j).Value = Worksheets("POr files").Range("E" & i).Value Then
                  Worksheets("POr files").Range("AG" & i).Value = Worksheets("Doc Buy").Range("J" & j).Value
                  Worksheets("POr files").Range("AH" & i).Value = Worksheets("Doc Buy").Range("R" & j).Value
                 Else
            End If
    Next i
Next j
 
Columns("AA:AA").Replace What:=".", Replacement:=","
For i = 2 To LR1
    If IsNumeric(Range("AA" & i)) = True Then
        Range("AA" & i).Value = Range("AA" & i).Value * 1
    End If
Next i
'environ 2" 6100
End Sub
____________________________________________________________________________
 
Sub vlookup2()
On Error Resume Next
Dim i As Long
Application.ScreenUpdating = False
Table1 = Worksheets("POr files").Range("E2:E6106") ' ID
table2 = Worksheets("Doc Buy").Range("A7:AB706") ' data source
 
i = 2
        For Each cl In Table1
            Worksheets("POr files").Cells(i, 32) = Application.WorksheetFunction.vlookup(cl, table2, 10, False)
            Worksheets("POr files").Cells(i, 33) = Application.WorksheetFunction.vlookup(cl, table2, 18, False)
            i = i + 1
        Next cl
Application.ScreenUpdating = True
'environ 3" 14kl / 1"36 6100
End Sub

09/08/2018, 10h54
78chris

Bonjour

Quel est la finalité de la relation ?

Excel gère mal les listes de données volumineuses mais dans 2016 est intégré PowerQuery, dont c'est la vocation, qui ferait cela facilement et rapidement.

Poste un exemple de quelques lignes dans chaque onglet et détaille le résultat souhaité : je te donnerai les manips à faire pour la requête PowerQuery

Il faut éviter les multiples accès à la feuille Excel
et préférer travailler en mémoire en utilisant de tableaux et des dictionnaires

=> activer (cocher en vba) la reference Microsoft Scripting runtime

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
option explicit
Sub vlookup_2b()
 
Dim i As Long
dim table1 as variant, table2 as variant ' tableaux
dim tabR as variant
Dim dico As new Scripting.Dictionary    ' dictionnaires cles -> valeur
 
Application.ScreenUpdating = False
 
 
'Table ou rechercher
table2 = Worksheets("Doc Buy").Range("A7:AB706").value ' data source
for i = lbound(table2,1) to ubound(table2,1)  ' pour i = 7 to 706)
    if not dico.Exists(table2(i,1) then dico.add table2(i,1), table2(i,10) & "¤" &  table2(i,18)' cle -> valeur
next i
set table2=Nothing
 
'Table ce que l'on cherche
Table1 = Worksheets("POr files").Range("E2:E6106").value ' ID
redim tabR ( lbound(table1,1) to ubound(table1,1), 1 to 2) ' x lignes et 2 colonnes,   lbound(table1,1) premiere ligne .. on aurait  lbound(table1,2) pour premiere colonne
for i = lbound(table1,1) to ubound(table1,1)   
    if  dico.Exists (table1(i,1)) then 
         ' la cle existe dans table 2 : recherche Ok
          tabR(i,1) = split(dico(table1(i,1) ,"¤")(0)
          tabR(i,2) = split(dico(table1(i,1) ,"¤")(1)
   end if
next i
 
'Ecrire le resultat dans Excel
with Worksheets("POr files")
       .range(.cells(2,32),.cells(6106,33)) = tabR
end with
 
End Sub

09/08/2018, 13h41
chanasb

Bonjour,
Tout d'abord merci à vous pour vos réponses et votre réactivité c'est incroyable !

@Chris
L'idée c'est de regrouper des extractions de donnée de différent logiciel une fois par mois, mutualiser les informations produits sur une feuille excel pour apporter une aide à la décision dans un processus d'approvisionnement. Les BI qu'on a dans ma société pour la mise en relation de table ne permettent pas l'écriture d'ou mon passage par excel. Je sais pas si je suis très clair.

@sogedic
Fabuleux ! je pensais gagner 2minutes sur l'exécution mais avec ton code tout est résolu en un claquement de doigt !
Est-ce que tu peux m'apporter un peu plus d'explications sur son fonctionnement. Je suis en phase d'initiation avec VBA et grandement intéresser pour comprendre comment ton script fonctionne.

En vous remerciant encore,
09/08/2018, 13h57
78chris

RE

PowerQuery intégré à Excel 2016 fait partie de PowerBI mais comme tu es dans Excel tu peux ensuite faire ce que tu veux...

Cela évite de plus en plus le VBA pour la manipulation de tables de données.
09/08/2018, 14h11
sogedic
Voici quelques explications

Le truc c'est de ne pas lire/ecrire/rechercher dans excel : chaque accès plombe le programme
1. mettre les données dans un tableau (variant) : t=Range("").value
2. boucler sur les lignes du tableau … en memoire
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Sub cc() Dim t As Variant t = Range("A1:C25").Value 'lignes MsgBox LBound(t, 1) '1 MsgBox UBound(t, 1) '25 'colonnes MsgBox LBound(t, 2) '1 MsgBox UBound(t, 2) '3 End Sub
pour chaque ligne on calcul un résultat (ici recherchev) que l'on met dans un autre tableu
et seulement a la fin, les résultats sont ecrit dans excel : une seule écriture

Pour les dictionnaires : il permettent de lister des valeurs contenus dans une feuille
https://excel-malin.com/tutoriels/vb...nnaire-en-vba/

si dans la feuille on a
toto 25 nantes
titi 23 nice

le dico, associe a une clé une valeur, pour en ramener plusieurs valeurs on peut utiliser un séparateur puis la fonction split
Code:

1 2 3 4 dico("toto")=25 ¤ nantes split(dico("toto"),"¤")(0)=25 split(dico("toto"),"¤")(1)=nantes
13/08/2018, 09h56
chanasb

Bien noté je vais potasser un peu tout ça en te remerciant encore

Bonjour,
Avec la fonction rechercheV tu n'as pas besoin de double boucles!
Code:

1 2 3 with Worksheets("POr files") .Range(.range("AG7"),.cells(.cells.rows.count,"AG").end(xlup)).formular1c1="=recherchV(paramètres") En with

Bonjour,

Je souhaite adapter le super code de Sogedic avec comme identifiant (/clef) sur chaque feuille une concaténation. Ma première concaténation sur le fichier data source est fonctionnelle en revanche la deuxième pas du tout j'ai un peu mélanger mes pinceaux entre mes variantes en fin de compte le table2 est la concaténation et conca2 le tableau source de cette concaténation =S.
Dans la mesure du possible j'aimerai éviter de créer une colonne en dur dans mon tableau pour ne pas ralentir l'exécution du code.

En vous remerciant par avance comme toujours :),

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub vlookup()
Dim i As long, j As Long, k As Long
Dim table1 As Variant, table2 As Variant, tabR As Variant ' tableaux
Dim conca As Variant, conca2 As Variant
 
Dim dico As New Scripting.Dictionary    ' dictionnaires cles -> valeur
 
 'Table ou rechercher
table2 = Worksheets("Doc Buy").Range("A7:Z1000").Value ' data source
For i = LBound(table2, 1) To UBound(table2, 1) ' Pour i = 7 to 706
    conca = table2(i, 1) & table2(i, 9)
    If Not dico.Exists(conca) Then dico.Add conca, table2(i, 8) & "¤" & table2(i, 16) ' cle -> valeur
Next i
Set table2 = Nothing
 
'Table ce que l'on cherche
conca2 = Worksheets("POr file").Range("A2:R20000").Value ' ID
For k = LBound(conca2, 1) To UBound(conca2, 1)
    table1 = conca2(k, 4) & conca2(k, 15)
Next k
ReDim tabR(LBound(table1, 1) To UBound(table1, 1), 1 To 2) ' x lignes et 2 colonnes,   lbound(table1,1) premiere ligne .. on aurait  lbound(table1,2) Pour premiere colonne
For j = LBound(table1, 1) To UBound(table1, 1)
    If dico.Exists(table1(j, 1)) Then
         ' la cle existe dans table 2 : recherche Ok
          tabR(j, 1) = Split(dico(table1(j, 1)), "¤")(0)
          tabR(j, 2) = Split(dico(table1(j, 1)), "¤")(1)
   End If
Next j
 
'Ecrire le resultat dans Excel
With Worksheets("POr file")
       .Range(.Cells(2, 24), .Cells(20000, 25)) = tabR
       End With
 
Application.ScreenUpdating = True
End Sub