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