Recherche de fichiers dans répertoire et sous dossiers

Bonjour,

Dans ce code, je peux avoir une liste de fichiers dans un répertoire en sélectionnant l'extension.

Par contre je suis limité au 1er niveau du sous répertoire.

Comment peut on lire les répertoires de 2e voire 3e niveau ou la totalité des sous-repertoire du dossier sélectionné

Merci pour votre aide

Option Explicit
Dim Data()
Dim NBdata As Long
Sub FichiersdansNdossiers()
Dim chemin As String
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim J As Long
Dim LeChemin As String
Set objShell = CreateObject("Shell.Application")
 Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
 'Si l'utilisateur annule sans choisir
If objFolder Is Nothing Then
'message
MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
Set oFolderItem = objFolder.Items.Item

With Range("A:A")
        .ClearContents
        .Interior.ColorIndex = xlNone
End With

 chemin = oFolderItem.Path
 Sheets("Liste Fichiers").Range("G1").Value = chemin

 Application.ScreenUpdating = False
  LeChemin = Cells(1, 7)
  LireRepertoir LeChemin, True
  With Sheets("Liste Fichiers")
    .Range("A1").Resize(UBound(Data, 2), 3) = Application.Transpose(Data)
  End With

End If
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
Dim extension As String

extension = InputBox("Indiquez l'extension désirée.", "Extension", "Tout fichier")
  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
  If extension = "" Then Exit Function
  If extension = "Tout fichier" Then
  NBdata = NBdata + 1
    ReDim Preserve Data(1 To 4, 1 To NBdata)
    Data(1, NBdata) = F1.ParentFolder & "\" & F1.name
    End If

  Ext = LCase(Right(F1.name, 3))
    If Ext = extension Then 'extension à adapter
    NBdata = NBdata + 1
    ReDim Preserve Data(1 To 4, 1 To NBdata)
    Data(1, NBdata) = F1.ParentFolder & "\" & F1.name
    End If
    Next F1
Return
End Function

 

Salut,

Dans le fichier ci-joint se trouve un code qui te permet de passer en revue tous les fichiers compris dans le même dossier que celui dans lequel tu le places, ainsi que tous les fichiers des sous-dossiers, sous-sous-dossiers, etc.

Attention, la colonne D est utilisée par le code.

Ça va dans le bon sens ?

Cordialement.

Super.

Exactement ce qu'il me fallait