Sub ListeFichiersTxt()
Dim Dossier As Object, Fichier As Object, Ws As Object
Dim StrSearchString As String, Chemin As String
Dim I As Byte
Dim FoundCell As Range
Dim PA As String
Application.ScreenUpdating = False
I = 10
StrSearchString = InputBox(Prompt:="Saisir Le Nom du Client ?.", Title:="Recherche")
If StrSearchString = "" Then Exit Sub
Range("B10:B50").ClearContents
Chemin = ThisWorkbook.Path
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
If Right(Fichier.Name, 3) = "xls" Then
If Fichier.Name <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Fichier
For Each Ws In Worksheets
With Ws
.Activate
Set FoundCell = .Cells.Find(What:=StrSearchString, LookIn:=xlValues, LookAt:=xlPart)
If Not FoundCell Is Nothing Then
PA = FoundCell.Address
Do
FoundCell.Activate
ThisWorkbook.Sheets(1).Cells(I, 2).Value = Fichier.Name & " --> Feuille: " & Ws.Name & "--> Cellule " & FoundCell.Address
I = I + 1
FoundCell = .Cells.Findext(FoundCell)
Loop While Not FoundCell Is Nothing And FoundCell.Address <> PA
End If
End With
Next Ws
ActiveWorkbook.Close savechanges:=False
End If
End If
Next Fichier
Application.ScreenUpdating = True
End Sub