Sub Lancer()
Dim Cel As Range, sPath As String
Dim ListFic As New Collection, Nb As Integer
' Dossier de départ
sPath = ThisWorkbook.Path & "\RESEAUX\"
' Piur chaque cellule remplie de la colonne a
For Each Cel In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Cel <> "" Then
ChercheFichier sPath, Cel.Value, ListFic
For Nb = 1 To ListFic.Count
Cells(Cel.Row, 1 + Nb).Value = ListFic(Nb)
Next Nb
' Vider la colection
Set ListFic = New Collection
End If
Next Cel
End Sub
Sub ChercheFichier(dossierDépart, nomFichier, Retour As Collection)
'renvoie dans la variable "retour" le chemin complet de "nomFichier"
'cherché dans "dossierDépart" (antislash final requis)
Dim fso, Fichiers, Fichier, Dossier, Racine, SousDossiers
Set fso = CreateObject("Scripting.FileSystemObject")
Set Racine = fso.GetFolder(dossierDépart)
Set Fichiers = Racine.Files
For Each Fichier In Fichiers
If UCase(Fichier.Name) Like UCase(nomFichier & ".*") Then
On Error Resume Next
Retour.Add Fichier.Path, Fichier.Path
On Error GoTo 0
End If
Next
' Récursivité
Set SousDossiers = Racine.SubFolders
For Each Dossier In SousDossiers
ChercheFichier Dossier, nomFichier, Retour
Next
End Sub