Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim NbFichiers As Long
 
Private Sub Entete()
    With ShFichiers
        .Cells.Clear
        .Range("A3" ) = "Nom"
        .Range("B3" ) = "Date de Création"
        .Range("C3" ) = "Date Dernière Modification"
        .Range("D3" ) = "Date Dernier accès"
    End With
End Sub
 
Private Sub Import(sDossier As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim LastRow As Long
    Application.ScreenUpdating = False
    QueryPerformanceCounter Debut
 
    NbFichiers = 0
    Entete
    ListeFichiersDans sDossier, True
 
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    ShFichiers.Rows("3:3" ).Font.Bold = True
    ShFichiers.Columns("B:D" ).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    ShFichiers.Columns("A:K" ).Columns.AutoFit
 
    LastRow = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
    ShFichiers.Range("B4:D" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
 
    Tri
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    Application.StatusBar = "Terminé : " & NbFichiers & " / " & Format((Fin - Debut) / Freq, "0.00 s" )
    Application.ScreenUpdating = True
End Sub
 
Private Sub ListeFichiersDans(sDossierSource As String, bInclureSousDossiers As Boolean)
Dim FSO As Object
Dim DossierSource As Object
Dim SousDossier As Object
Dim Fichier As Object
Dim r As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject" )
    Set DossierSource = FSO.GetFolder(sDossierSource)
 
    r = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
 
    For Each Fichier In DossierSource.Files
        If UCase$(Fichier.Name) Like ("*.XLS" ) Then
            r = r + 1
            With ShFichiers
                .Cells(r, 1) = Fichier.Name
                .Cells(r, 2) = Fichier.DateCreated
                .Cells(r, 3) = Fichier.DateLastModified
                .Cells(r, 4) = Fichier.DateLastAccessed
                NbFichiers = NbFichiers + 1
            End With
        End If
        Application.StatusBar = NbFichiers
    Next Fichier
 
    If bInclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDans SousDossier.Path, True
        Next SousDossier
    End If
 
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Sub SelDossier()
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
            DoEvents
            Import .SelectedItems(1)
        End If
    End With
    ShFichiers.Range("B1" ).Select
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    LastRow = ShFichiers.Range("A" & Rows.Count).End(xlUp).Row
 
    ShFichiers.Range("A4:D" & LastRow).Sort Key1:=ShFichiers.Range("A4" ), Order1:=xlAscending, _
                                            Key2:=ShFichiers.Range("B4" ), Order2:=xlAscending, _
                                            Key3:=ShFichiers.Range("C4" ), Order3:=xlAscending, _
                                            Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                            DataOption1:=xlSortNormal, _
                                            DataOption2:=xlSortNormal, _
                                            DataOption3:=xlSortNormal
    ShFichiers.Range("B1" ).Select
End Sub