Sub RecupFichier()
Dim Tbl() As String
Dim TblRecup() As String
Dim Dossier As String
Dim Critere As String
Dim I As Integer
Dim J As Integer
'adapter le chemin
Dossier = "D:\MonDossier\"
'récupère les tous les fichiers du dossier
Tbl = Fichiers(Dossier)
'défini le critère de recherche
Critere = "MonCritere"
'parcour le tableau afin de rechercher
'le critère dans les noms des classeurs
For I = 1 To UBound(Tbl)
'si trouvé
If InStr(Tbl(I), Critere) Then
'regarde dans les noms des feuilles du classeur si le critère
's'y trouve aussi, si c'est le cas, récupère dans un autre tableau
'le chemin et le nom du classeur
If FeuilleExiste(Dossier & Tbl(I), Critere) = True Then
J = J + 1
ReDim Preserve TblRecup(1 To J)
TblRecup(J) = Dossier & Tbl(I)
End If
End If
Next I
'ici, affiche les classeurs qui peuvent correspondre
For I = 1 To UBound(TblRecup)
Debug.Print TblRecup(I)
Next I
End Sub
'fonction tableau qui retourne tous les
'fichiers du dossier passé en argument
Function Fichiers(Chemin As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
I = I + 1
ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Fichier
Fichier = Dir()
Loop
Fichiers = TableauFichiers()
End Function
Function FeuilleExiste(Fichier As String, _
Critere As String) As Boolean
Dim Con As Object
Dim Cat As Object
Dim Feuille As Object
'crée les objets de connection au classeur
Set Con = CreateObject("ADODB.Connection")
Set Cat = CreateObject("ADOX.Catalog")
Set Feuille = CreateObject("ADOX.Table")
Con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& Fichier & _
";Extended Properties=Excel 8.0;"
Set Cat.ActiveConnection = Con
'parcour la collection de feuilles du classeur
'pour voir si le critère se trouve dans un des noms
'de feuille, si oui, retourne vrai
For Each Feuille In Cat.Tables
If InStr(Feuille.Name, Critere) <> 0 Then
FeuilleExiste = True
GoTo Fin
End If
Next Feuille
'mets fin à la connection
Fin:
Con.Close
Set Con = Nothing
Set Cat = Nothing
Set Feuille = Nothing
End Function