'------------------------------------------------------------
'
'  VBE Outils/Références Cocher Microsoft Scripting Runtime
'
'------------------------------------------------------------
 
Option Explicit
 
Public Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Public Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim Cpt As Long
 
'   Const TypeFichier As String = "##.xls"
'   Const TypeFichier As String = "trans_###_########.txt"
Const TypeFichier As String = "*.xls"
 
Sub Tst()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Cpt = 0
            Application.StatusBar = ""
            DoEvents
            Lire .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub Lire(sPath As String)
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim Coll As Collection
Dim i As Long
 
    Application.ScreenUpdating = False
    QueryPerformanceCounter Dep
    Set Coll = New Collection
 
    ShFichiers.Cells.Clear
    ListeFichiers sPath, Coll, True
 
    For i = 1 To Coll.Count
        ShFichiers.Range("A" & i) = Coll.Item(i)
    Next i
 
    Set Coll = Nothing
 
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    With Application
        ShFichiers.Range("B1" ).Select
        .StatusBar = "Terminé : " & Cpt &  " / " & Format(((Fin - Dep) / Freq), "0.00 s" )
        .ScreenUpdating = True
    End With
End Sub
 
Private Sub ListeFichiers(sChemin As String, Coll As Collection, Recursif As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim Dossier As Scripting.Folder
Dim SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
 
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        If UCase(Fichier.Name) Like UCase(TypeFichier) Then
            Cpt = Cpt + 1
            Coll.Add Fichier.Path
            Application.StatusBar = Cpt  
        End If
    Next Fichier
 
    If Recursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, Coll, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Function