XL 2016 liste des sous répertoire

Option Explicit
Private TRés(), LCou As Long, FSO As New FileSystemObject
Sub ListeFic()
   ReDim TRés(1 To 10000, 1 To 2)
   LCou = 0
   Lister FSO.GetFolder(ActiveSheet.Cells(2, "D").Value)
   ActiveSheet.Rows(3).Resize(10000).Delete
   ActiveSheet.[A3].Resize(LCou, 2).Value = TRés
   Erase TRés
   End Sub
Private Sub Lister(ByVal Fdr As Scripting.Folder)
   Dim ChemDoss As String, FdrS As Scripting.Folder, Fle As Scripting.File
   ChemDoss = Fdr.Path
   On Error Resume Next
   For Each Fle In Fdr.Files
      If Fle Is Nothing Then Exit For
      LCou = LCou + 1
      TRés(LCou, 1) = ChemDoss
      TRés(LCou, 2) = Fle.Name
      Next Fle
   For Each FdrS In Fdr.SubFolders
      If FdrS Is Nothing Then Exit Sub
      Lister FdrS: Next FdrS
   End Sub

Sub BoucleFichiers()
Dim EF As Object 'déclare la variable EF (Exporateur de Fichiers)
Dim D As Object 'déclare la variable D (Dossier)
Dim SD As Object 'déclare la variable SD (Sous Dossier)
Dim SDT As Object 'déclare la variable SDT (Sous Dossier Trouvé)
Dim I As Integer 'déclare la variable I (Incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set EF = CreateObject("Scripting.FileSystemObject") 'définit la variable EF
Set D = EF.GetFolder(Range("D2").Value) 'définit la variable D
Set SD = D.Subfolders 'définit la variable SD
For Each SDT In SD 'boucle sur tous les sous dossier trouvé
    I = I + 1 'incrémente I
    Cells(I, 2).Value = SDT.Name 'renvoie le nom du sous dossier trouvé dans la cellule ligne I colonne
Next SDT 'prochain sious dossier trouvé de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Terminé !" 'message
End Sub

Sub ExtraireTousLesRepertoires1()
    Dim Chemin As String, Fichier As String, i As Integer
    Dim R As Object
    Set R = CreateObject("scripting.filesystemobject")
    Columns(2).ClearContents
    If Right(Range("D2"), 1) <> "\" Then Chemin = Range("D2") & "\" Else: Chemin = Range("D2")
    ChDir (Chemin)
    myFolder = CurDir(Chemin)
    Set mainFolder = R.GetFolder(myFolder)
    For Each f In mainFolder.SubFolders
        i = i + 1
        Cells(i, 2) = f
    Next f
End Sub


Sub ExtraireTousLesRepertoires2()
    Columns(3).ClearContents
    If Right(Range("D2"), 1) <> "\" Then Chemin = Range("D2") & "\" Else: Chemin = Range("D2")
    SousRep = Dir(Chemin, vbDirectory)
    i = 1
    Do While SousRep <> ""
        If SousRep <> "." And SousRep <> ".." Then
            If (GetAttr(Chemin & SousRep) And vbDirectory) = vbDirectory Then
                Cells(i, "C") = SousRep
                i = i + 1
            End If
        End If
        SousRep = Dir
    Loop
End Sub