Lister repertoires et sous-répertoires.

Public Chemin As String, dossier, TableauListeDossierEncours, T1
Sub Liste_Dossier_Select()
T1 = Timer
NomAScanner = ActiveCell.Text: If NomAScanner = "" Then Exit Sub
Sheets.Add: Nom1 = Replace(NomAScanner, ":", " "): Nom2 = Replace(Nom1, "\", " "): If Len(Nom2) < 31 Then ActiveSheet.Name = Nom2 Else ActiveSheet.Name = Mid(Nom2, 1, 31)
Cells(1, 1).Value = NomAScanner
Liste_Dossier_Sous_Dossiers_OK
'Stop
'Ajouter ordre et alea
Derl = Cells(Rows.Count, 1).End(xlUp).Row
'AjouterCode
Selection.AutoFilter
    Selection.AutoFilter
 
Application.StatusBar = Format(Timer - T1, "0.0") & " secondes"
End Sub
Sub Liste_Dossier_Sous_Dossiers_OK()
    
        Application.ScreenUpdating = False
    Set F = ActiveSheet
    If F.FilterMode Then F.ShowAllData
    If Not F.AutoFilterMode Then F.Range("A1").AutoFilter

    Range(Cells(2, 1), Cells(Rows.Count, 10)).Clear
    Dim TableauListeDossier(1000000)
    dossier = [A1]
    Liste_Dossiers_SousDossiers
    Derl = Cells(Rows.Count, 1).End(xlUp).Row: If Derl = 1 Then Derl = 2
    'Stop
    For i = 1 To Derl
        TableauListeDossier(i) = Cells(i, 1).Value
    Next
    'Stop
    Range(Cells(2, 1), Cells(Derl, 10)).Clear
    For i = 1 To Derl
        TableauListeDossierEncours = TableauListeDossier(i)
        ListeFichierDossierEnCours (TableauListeDossier(i))
    Next
    'Tri_Desc_Date
    Application.ScreenUpdating = True
    'MsgBox Format(Timer - t1, "0.0")
    MEF_ListeFichiers
    
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
    On Error Resume Next
    Idx = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each Flder In dossier.subfolders
        Cells(Idx, 1).Value = Flder.Path
        Idx = Idx + 1
    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
Sub Liste_Dossiers_SousDossiers()
'TousLesDossiers "D:\LUI\Developement\VB_VBA\", 0
    TousLesDossiers [A1], 0
    'Tableau de chaque dossier puis listage de chaque dossier
End Sub
Sub ListeFichierDossierEnCours(Chemin As String)
    Dim dossier As Object, Fichier As Object
    Dim i As Long
    'Chemin du dossier à analyser (à adapter au besoin)
    'Chemin = ThisWorkbook.Path
    'Chemin = ActiveSheet.Range("A1").Value    'Sheets("paramètrage").Range("b5").Value
    'Définition de la variable
    On Error Resume Next
    If Chemin = "" Then Exit Sub
    Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
    ' Boucle sur les fichiers
    'Range("a2").Select
    '    Stop
    i = Cells(Rows.Count, 1).End(xlUp).Row + 1
    For Each Fichier In dossier.Files
        Cells(i, 1).Formula = TableauListeDossierEncours
        'Cells(i, 1).Formula = Fichier.Path
        'Cells(i, 1).Formula = Range("A1").Value
        Cells(i, 2).Formula = Fichier.Name
        Cells(i, 3).Formula = Fichier.Size
        Cells(i, 4).Formula = Fichier.DateLastModified    'DateCreated'DateLastAccessed
        i = i + 1
    Next
End Sub
Sub MEF_ListeFichiers()
    'Columns("B:D").Select
    'Columns("B:D").EntireColumn.AutoFit
    'Columns("A:A").Select
    Columns("A:B").ColumnWidth = 40
    Columns("C:D").ColumnWidth = 20
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Nom"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Taille"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Date"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Ordre"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Aléatoire"
    Range("F1").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Columns("C:D").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = False
    Columns("E:F").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = False
    
    'Range("C").Select
    With Range("C:C")
        .HorizontalAlignment = xlRight 'xlLeft'xlcenter
        .VerticalAlignment = xlCenter
        .NumberFormat = "#,##0"
    End With
    
    Range("B1").Select
End Sub