Liste des fichiers et des sous-répertoires d'un répertoire

Bonjour,

j'aimerais lister les fichiers de sous répertoires d'un répertoire principal.

Le résultat doit apparaître dans une colonne excel avec le chemin complet.

Je sais lister les fichiers d'un répertoire avec ce code

Sub Liste_fichier()
'
' Liste_fichier Macro
' Crée la liste des fichiers d'un répertoire

Dim Fichier, Lig As Integer
Dim CheminSource As String
    'Adapter le chemin
   CheminSource = Cells(1, 7)
    If CheminSource = "" Then
        MsgBox ("Le chemin de sauvegarde doit etre defini dans la cellule G1 !")
      Exit Sub
    End If

    Fichier = Dir(CheminSource)
    Do While Fichier <> ""
        Lig = Lig + 1
        ActiveSheet.Cells(Lig, 1) = Fichier
        Fichier = Dir
    Loop

Application.StatusBar = "Traitement terminé."
    MsgBox ("Traitement terminé")
End Sub

Quelqu'un peut il m'aider à l'adapter.

Merci

Bonjour

Regarde si tu peux adapter ce fichier

Cordialement

Merci Amadéus,

en fait je suis reparti de ce code que j'ai modifié.

Je l'ai adapté pour connaitre soit les fichiers d'un dossier, soit les fichiers de plusieurs sous dossiers

Option Explicit
Dim Data()
Dim NBdata As Integer
Sub Lecture()
Dim LeChemin  As String
Dim J As Long

  Application.ScreenUpdating = False
  LeChemin = Cells(1, 7)
  If LeChemin = "" Then
        MsgBox ("Le chemin de sauvegarde doit etre defini dans la cellule G1 !")
      Exit Sub
    End If

  If LeChemin = "" Then Exit Sub
  LireRepertoir LeChemin, True

  With Sheets("Liste Fichiers")
    .Range("A1").Resize(UBound(Data, 2), 3) = Application.Transpose(Data)
  End With

End Sub
'Obtenir tous les fichiers d'un répertoire et éventuellement des sous-répertoires
'Si SousRep = true
'Le répertoire source doit être dans Rep
Public Function LireRepertoir(ByVal Rep As String, Optional SousRep As Boolean) As Integer
Dim Obj, RepP, F, S, sf, F1, Fsous
Dim i As Integer, Ext As String
Dim Chem As String
Dim T As Double

  NBdata = 1
  ReDim Data(1 To 4, 1 To NBdata)
    Set Obj = CreateObject("Scripting.FileSystemObject")
    Set RepP = Obj.Getfolder(Rep)
    Chem = Rep: If Right(Chem, 1) <> "\" Then Chem = Chem & "\"

    Set sf = RepP.subfolders
    Set F = RepP.Files
    GoSub RempliData                        'les fichiers du répertoire principal
    If SousRep Then                         'les fichiers des sous-répertoires
        For Each Fsous In sf
            Set RepP = Fsous
            Set F = RepP.Files
            GoSub RempliData
        Next Fsous
    End If
Exit Function
'**********************************************************************
RempliData:
  For Each F1 In F
    NBdata = NBdata + 1
    ReDim Preserve Data(1 To 4, 1 To NBdata)
    Data(1, NBdata) = F1.ParentFolder & "\" & F1.Name
    Next F1

Return

End Function

Cordialement