Optimisation d'une procédure

Version imprimable

Bonjour,

La procédure ci-dessous me permet d'extraire des données d'une bdd au format DBF (Visual FoxPro) et de les insérer dans un tableur excel.
Bien qu'elle fonctionne, son exécution prend 20 min environ.

Le problème commence à partir de la ligne 30, ou je dois récupérer une désignation, dans une autre bdd, à l'aide d'une référence.

J'aimerais avoir vos conseils pour optimiser cette procédure au mieux possible.

Merci d'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
43
44
45
46
47
48
49
50
51
52
Option Explicit
 
Sub Mise_a_jour()
On Error GoTo fin
Dim Lignes As Long, i As Long
Dim Temps_1 As Date, Temps_2 As Date
Dim Tableau As Variant
Dim cnx As ADODB.Connection
Dim rst As ADODB.Recordset
Set cnx = New ADODB.Connection
Set rst = New Recordset
Temps_1 = Time
cnx.Open "Driver={Microsoft Visual FoxPro Driver};SourceDB=C:\Fichiers;SourceType=DBF;Exclusive=No"
 
With ThisWorkbook.Sheets("Bons de livraison")
    Lignes = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A4:D" & Lignes).ClearContents 'Suppression des anciennes données
 
    rst.Open "SELECT GPCOLIS.CO_EXPE, GPCOLIS.CO_NSER, GPCOLIS.CO_CART FROM GPCOLIS WHERE LEFT(GPCOLIS.CO_CART, 1) = 'C'", cnx
    .Range("A4").CopyFromRecordset rst 'Import des nouvelles données
    rst.Close
 
    Lignes = .Range("A" & Rows.Count).End(xlUp).Row
    Tableau = .Range("A4:D" & Lignes)
 
    For i = 1 To UBound(Tableau)
        Tableau(i, 2) = Trim(Tableau(i, 2)) 'Suppression des espaces en fin de lignes (Bizarrement, les données sont importées avec des espaces superflus à la fin des champs 2 et 3)
        Tableau(i, 3) = Trim(Tableau(i, 3))
 
        'CETTE PARTIE EST LA PLUS LONGUE
        'Récupère la désignation depuis une autre bdd, avec la référence du produit
        rst.Open "SELECT GPARTICL.AR_CODE, GPARTICL.AR_DES1 FROM GPARTICL WHERE GPARTICL.AR_CODE = '" & Tableau(i, 3) & "'", cnx
        Tableau(i, 4) = Trim(rst.Fields(1))
        rst.Close
    Next i
 
    .Range("A4:D" & Lignes).ClearContents 'Suppression des anciennes données
    .Range("A4:D" & Lignes).FormulaLocal = Tableau 'Importation des nouvelles
End With
 
cnx.Close
 
Temps_2 = Time
MsgBox "Mise à jour terminée en " & Format(CDate(Temps_2 - Temps_1), "n""mn ""s""sec")
 
Erase Tableau
Set cnx = Nothing
Set rst = Nothing
Exit Sub
fin:
MsgBox "Echec de la mise à jour"
End Sub

23/07/2020, 19h25
Menhir

Je ne connais pas Visual FoxPro mais, si je ne me trompes pas, le format BDF, c'est celui de dBase, un SGDB qui a eu un certain succès à la fin des années 80 (surtout sa version 3), avant l'avènement de Windows 3.

Si c'est bien de ça qu'il s'agit, Excel sait ouvrir ses fichiers.
ll suffira donc d'un simple Workbooks.Open pour l'ouvrir.

Le traiter en tant que Classeur sera plus simple qu'en ADO.
24/07/2020, 08h22
atk_49

Bonjour Menhir,

Oui tu as raison, il s'agit bien de ce format qui s'ouvre directement avec excel. J'ai exploité cette fonctionnalité dans une précédente procédure, mais mes fichiers dbf étant très lourds le temps d'exécution était très important.

Selon toi, est-il plus efficace de faire une boucle sur une requête comme je l'ai fait, ou d'enregistrer la bdd dans une variable tableau et de boucler à l'intérieur ?
Si je retiens cette idée, y a t il plus efficace que MATCH pour identifier le positionnement d'une valeur dans un tableau ?

Merci et bonne journée.
24/07/2020, 08h47
Menhir

Citation:

Envoyé par atk_49

Selon toi, est-il plus efficace de faire une boucle sur une requête comme je l'ai fait, ou d'enregistrer la bdd dans une variable tableau et de boucler à l'intérieur ?

Tu attends que je fasse le test à ta place ?

Citation:

Si je retiens cette idée, y a t il plus efficace que MATCH pour identifier le positionnement d'une valeur dans un tableau ?

Méthode Find de Range.
Lire ça : https://msdn.microsoft.com/fr-fr/lib...6(v=office.15)

Solution trouvée ici

Avec cette méthode, l'exécution de la procédure entière prends 2 secondes :mrgreen:

Je partage avec vous le code définitif, si vous voyez des choses à améliorer n'hésitez surtout pas.

Une remarque malgré tout, d'après le site de Jacques Boisgontier, cette méthode ne fonctionne que si la colonne ne contient que des clés uniques, sinon il faut utiliser des pseudos clés. (voir le lien)

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Option Explicit
 
Sub Mise_a_jour()
On Error GoTo fin
Dim j As Byte
Dim Lignes As Long, i As Long, k As Long
Dim Temps_1 As Date, Temps_2 As Date
Dim Tableau_1 As Variant, Tableau_2 As Variant
Dim Dico As Object
Dim cnx As ADODB.Connection
Dim rst As ADODB.Recordset
Set cnx = New ADODB.Connection
Set rst = New Recordset
Set Dico = CreateObject("Scripting.Dictionary")
Temps_1 = Time
cnx.Open "Driver={Microsoft Visual FoxPro Driver};SourceDB=C:\Fichiers;SourceType=DBF;Exclusive=No"
 
'Mémorise les désignations
rst.Open "SELECT GPARTICL.AR_CODE, GPARTICL.AR_DES1 FROM GPARTICL WHERE LEFT(GPARTICL.AR_CODE, 1) = 'C'", cnx
Tableau_1 = Application.Transpose(rst.GetRows)
rst.Close
 
For i = 1 To UBound(Tableau_1)
    Tableau_1(i, 1) = Trim(Tableau_1(i, 1)) 'Suppression des espaces en fin de lignes
    Tableau_1(i, 2) = Trim(Tableau_1(i, 2))
    Dico(Tableau_1(i, 1)) = i 'Intègre les références dans un dictionnaire
Next i
 
With ThisWorkbook.Sheets("Bons de livraison")
    .Range("A4:D80000").ClearContents 'Suppression des anciennes données
 
    rst.Open "SELECT GPCOLIS.CO_EXPE, GPCOLIS.CO_NSER, GPCOLIS.CO_CART FROM GPCOLIS WHERE LEFT(GPCOLIS.CO_CART, 1) = 'C'", cnx
    .Range("A4").CopyFromRecordset rst 'Import des nouvelles données
    rst.Close
 
    Lignes = .Range("A" & Rows.Count).End(xlUp).Row
    Tableau_2 = .Range("A4:D" & Lignes)
 
    For i = 1 To UBound(Tableau_2)
        Tableau_2(i, 2) = Trim(Tableau_2(i, 2)) 'Suppression des espaces en fin de lignes
        Tableau_2(i, 3) = Trim(Tableau_2(i, 3))
 
        If Tableau_2(i, 2) = vbNullString Then 'Supprime les lignes sans numéro de série
            For j = 1 To 3
                Tableau_2(i, j) = vbNullString
            Next j
        Else
            k = Dico(Tableau_2(i, 3)) 'Donne la position de la référence dans le dictionnaire et donc dans le Tableau_1
            Tableau_2(i, 4) = Tableau_1(k, 2) 'Désignation
        End If
    Next i
 
    With .Range("A4:D" & UBound(Tableau_2) + 3)
        .ClearContents
        .FormulaLocal = Tableau_2 'Importation des données
        .Sort key1:=.Range("A1"), order1:=xlAscending, DataOption1:=xlSortNormal 'Tri par numéro de BL
    End With
End With
 
cnx.Close
 
Temps_2 = Time
MsgBox "Mise à jour terminée en " & Format(CDate(Temps_2 - Temps_1), "n""mn ""s""sec")
 
Erase Tableau_1
Erase Tableau_2
Set Dico = Nothing
Set rst = Nothing
Set cnx = Nothing
Exit Sub
fin:
MsgBox "Echec de la mise à jour (ref : " & Tableau_2(i, 1) & ")"
End Sub

Bonne journée