bonsoir Deguste
la macro ci dessous liste tous les classseurs d'un repertoire dans la colonne A
dans la colonne B sont insérés les valeurs de la cellule A1 , de chaque classeur
Option Explicit
Dim X As Integer
Sub RecupererListeFichiersDansRepertoire()
Dim nbFichiers As Integer
Dim Tableau() As String, Cible As String , Valeur As String
Dim Direction As String
Direction = Dir("C:\Repertoire\*.xls") 'adapter chemin
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
If nbFichiers > 0 Then
MsgBox "il y a " & nbFichiers & " fichiers dans le repertoire . "
'pour afficher tous les noms de fichiers
For X = 1 To nbFichiers
Cells(X, 1) = Tableau(X)
Valeur = "C:\Repertoire\" & Tableau(X)
Cible = Cells(1, 1).Address(0, 0) & ":" & Cells(1, 1).Address(0, 0) 'plage des valeurs à recuperer
VaChercherMonLycos Valeur, Cible
'adapter chemin du fichier contenant les valeurs à recuperer
Next X
End If
End Sub
Public Sub VaChercherMonLycos(Fichier As String, Plage As String)
Dim dbConnection As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim dbConnectionString As String
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;" & "DBQ=" & Fichier
Set dbConnection = New ADODB.Connection
dbConnection.Open dbConnectionString
Set Rs = dbConnection.Execute("[" & Plage & "]")
Range("B" & X) = Rs.Fields(0).Name
Range("B" & X).CopyFromRecordset Rs
Rs.Close
dbConnection.Close
Set Rs = Nothing
Set dbConnection = Nothing
End Sub
necessite d'activer les references
Visual Basic For Applications
Microsoft Excel xx Object Library
OLE Automation
Microsoft Office xx Object Library
Microsoft ActiveX Data Objects 2.7 Library
Microsoft Forms 2.0 Object Library
bonne soiree
michel
