[XL-2003] Récupérer les données de plusieurs fichiers d'un même répertoire sans les ouvrir

[mattic59]

Bonjour,

J'ai récupéré un code que j'ai adapté pour récupérer les données d'un fichier excel en les copiant dans un autre de compil (cf. ci-dessous). En revanche je n'arrive pas à mettre en place une boucle qui me permettrait de :
- ouvrir tous les documents d'un répertoire (documents tous structurés exactement de la même façon)
- coller les données du 1er magasin sur la 3ème colonne , du second dans la 4ème, ...

Pourriez-vous m'aider et d'avance merci pour votre aide !!!

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
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim Fichier As String, Cellule As String, Feuille As String
 
'Adresse de la cellule contenant la donnée à récupérer
Cellule = "H8:H50"
Cellule2 = "C3:c4"
 
Feuille = "SYNTHESE$"
'Chemin complet du classeur fermé ==> que je souhaite remplacer par tous les fichiers d'un même répertoire
Fichier = "D:\XX\YY.xls"
 
 
Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
 
Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM [" & Feuille & Cellule2 & "]"
End With
 
Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
 
Set Rst = Source.Execute("[" & Feuille & Cellule2 & "]")
 
Range("A1").CopyFromRecordset Rst
Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
 
Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM [" & Feuille & Cellule & "]"
End With
 
Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
 
Set Rst = Source.Execute("[" & Feuille & Cellule & "]")
 
Range("A3").CopyFromRecordset Rst
Rst.Close
Source.Close
Set Source = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing
End Sub

[Theze]

Bonsoir,

Je n'ai absolument pas testé ta proc (je ne me suis pas penché sur ton code), j'ai juste rajouté une fonction tableau de recherche de fichiers Excel dans le dossier passé en argument et une boucle qui englobe ta requête, regarde si tu y arrive, sinon revient :

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
 
Sub Recup()
 
    Dim Source As ADODB.Connection
    Dim Rst As ADODB.Recordset
    Dim ADOCommand As ADODB.Command
    Dim Fichier As String
    Dim Cellule As String
    Dim Cellule2 As String
    Dim Feuille As String
 
    'variables rajoutées
    Dim Tbl() As String
    Dim Chemin As String
    Dim Test As Integer
    Dim I As Integer
 
    'Adresse de la cellule contenant la donnée à récupérer
    Cellule = "H8:H50"
    Cellule2 = "C3:c4"
 
    Feuille = "SYNTHESE$"
 
    'Chemin complet du classeur fermé ==> que je souhaite remplacer par tous les fichiers d'un même répertoire
    Chemin = "D:\XX\"
    Tbl() = ListeFichiers(Chemin)
 
    'test de l'existance d'au moins un fichier
    On Error Resume Next
 
    Test = UBound(Tbl)
 
    If Err.Number <> 0 Then
 
        MsgBox "Aucun fichier dans le dossier " & Chemin & " !"
        Err.Clear
        Exit Sub
 
    End If
 
    For I = 1 To UBound(Tbl)
 
        Fichier = Chemin & Tbl(I)
 
        Set Source = New ADODB.Connection
        Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
 
        Set ADOCommand = New ADODB.Command
 
        With ADOCommand
            .ActiveConnection = Source
            .CommandText = "SELECT * FROM [" & Feuille & Cellule2 & "]"
        End With
 
        Set Rst = New ADODB.Recordset
        Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
 
        Set Rst = Source.Execute("[" & Feuille & Cellule2 & "]")
 
        Range("A1").CopyFromRecordset Rst
        Set Source = New ADODB.Connection
        Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
 
        Set ADOCommand = New ADODB.Command
        With ADOCommand
            .ActiveConnection = Source
            .CommandText = "SELECT * FROM [" & Feuille & Cellule & "]"
        End With
 
        Set Rst = New ADODB.Recordset
        Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
 
        Set Rst = Source.Execute("[" & Feuille & Cellule & "]")
 
        Range("A3").CopyFromRecordset Rst
        Rst.Close
        Source.Close
 
    Next I
 
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
 
End Sub
 
Function ListeFichiers(Chemin As String) As String()
 
    Dim Tbl() As String
    Dim Fichier As String
    Dim I As Integer
 
    Fichier = Dir(Chemin)
 
    Do While (Len(Fichier) > 0)
 
        'seuls les fichiers Excel
        If InStr(Fichier, ".xls") <> 0 Then
 
            I = I + 1
            ReDim Preserve Tbl(1 To I)
            Tbl(I) = Fichier
 
        End If
 
        Fichier = Dir()
 
    Loop
 
    ListeFichiers = Tbl()
 
End Function

Hervé.