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 : Sélectionner tout - Visualiser dans une fenêtre à part
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