Liste de fichiers + Lire dans la liste

Option Explicit

Sub TheSearcher()
Dim ThisBookPath As String, TabFilePathName() As Variant
Dim FileSearcher As FileSearch
Dim ThePath As String
Dim i As Integer

Set FileSearcher = Application.FileSearch
ThisBookPath = ThisWorkbook.Path
ThePath = ThisBookPath

With FileSearcher
  .NewSearch
  .Filename = '*.xls*'
  .LookIn = ThePath
  .SearchSubFolders = True
  .Execute msoSortByFileName, msoSortOrderAscending
    If .Execute > 0 Then
        With .FoundFiles
            For i = 1 To .Count
            ReDim Preserve TabFilePathName(2, 0 To .Count - 1)
                TabFilePathName(0, i - 1) = .Item(i)
                TabFilePathName(1, i - 1) = Dir(.Item(i))
            Next i
        End With
    Else
        MsgBox 'Pas de Fichier trouvé dans ' & ThePath
        Exit Sub
    End If
End With
Set FileSearcher = Nothing

Range('A2').Resize(UBound(TabFilePathName, 2) + 1, UBound(TabFilePathName, 1)) = Application.Transpose(TabFilePathName)
End Sub

Cliquez pour agrandir...

Option Explicit

Const TheSheet As String = 'PURCHASING PLAN'
Const TheAddress As String = '$C$72'


Sub TheSearcher()
Dim ThisBookPath As String, TabFilePathName() As Variant
Dim FileSearcher As FileSearch
Dim ThePath As String
Dim i As Integer

Set FileSearcher = Application.FileSearch
ThisBookPath = ThisWorkbook.Path
ThePath = ThisBookPath

With FileSearcher
  .NewSearch
  .Filename = '*.xls*'
  .LookIn = ThePath
  .SearchSubFolders = True
  .Execute msoSortByFileName, msoSortOrderAscending
    If .Execute > 0 Then
        With .FoundFiles
            For i = 1 To .Count
            ReDim Preserve TabFilePathName(2, 0 To .Count - 1)
                TabFilePathName(0, i - 1) = .Item(i)
                TabFilePathName(1, i - 1) = Dir(.Item(i))
            Next i
        End With
    Else
        MsgBox 'Pas de Fichier trouvé dans ' & ThePath
        Exit Sub
    End If
End With
   
    Set FileSearcher = Nothing
    Range('A2').Resize(UBound(TabFilePathName, 2) + 1, UBound(TabFilePathName, 1)) = Application.Transpose(TabFilePathName)

TheFormulator
End Sub

Sub TheFormulator()
Dim Cell As Range
Dim TheFullPath As String
Dim ThePath As String
Dim TheFile As String
Dim TheFormula As String
    For Each Cell In Range('A2:A' & Range('A5000').End(xlUp).Row)
        TheFullPath = Cell.Text
        TheFile = Cell.Offset(0, 1).Text
        ThePath = Left(TheFullPath, Len(TheFullPath) - Len(TheFile))
        TheFormula = '='' & ThePath & '[' & TheFile & ']' & TheSheet & ''!' & TheAddress
        Cell.Offset(0, 2).Formula = TheFormula
    Next
End Sub

Cliquez pour agrandir...

Sub TheDirSearcher()
Dim FSO As Object, ObjDirectory As Object, ObjFolder As Object
Dim TheDirectory As String
Dim i As Integer

TheDirectory = InputBox('Nom du répertoire (niveau de départ)', 'NOM DU REPERTOIRE', 'UserName\\My Documents')
TheDirectory = 'C:\\Documents and Settings\\' & TheDirectory

Set FSO = CreateObject('Scripting.FileSystemObject')
On Error GoTo Out
Set ObjDirectory = FSO.GetFolder(TheDirectory)

        For Each ObjFolder In ObjDirectory.SubFolders
            i = i + 1
            Range('A' & i).Value = ObjFolder.Name
        Next

Set FSO = Nothing
Set ObjDirectory = Nothing
Exit Sub
Out:
If Err = 76 Then MsgBox 'Répertoire Non Trouvé ' & TheDirectory
Set FSO = Nothing
End Sub

Cliquez pour agrandir...

Sub Test()
    TousLesDossiers 'C:\\Documents and Settings\\', 0
End Sub

Sub TousLesDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object

Set fso = CreateObject('Scripting.FileSystemObject')
Set Dossier = fso.GetFolder(LeDossier)

'examen du dossier courant
For Each Flder In Dossier.SubFolders
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
Next

'traitement récursif des sous dossiers
For Each sousRep In Dossier.SubFolders
TousLesDossiers sousRep.Path, Idx
Next sousRep
Set fso = Nothing

End Sub 'fs <= Frederique Sigonneau

Cliquez pour agrandir...