Lister certains fichiers dans répertoire

Bonjour,

dans ce code, je liste les fichiers soit dans un seul dossier soit dans un répertoire avec des sous-répertoires

Quand je demande l'extension du fichier afin de ne ressortir que ce qui m'intéresses ou tous, cela marche avec la macro Fichiersdans1dossier par contre ça ne filtre pas dans FichiersdansNdossiers.

Fichiersdans1dossier

Sub Fichiersdans1dossier()

' Créé la liste des fichiers d'un dossier avec spécification de l'extension ou non

Dim Fichier, Lig As Integer
Dim CheminSource As String
Dim chemin As String
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim J As Long
Dim extension As String
extension = InputBox("Indiquez l'extension désirée.", "Extension", "Tous fichiers")
If extension = "" Then Exit Sub
If extension = "Tous fichiers" Then
        extension = "*"
End If
With Range("A:A")
        .ClearContents
        .Interior.ColorIndex = xlNone
End With

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

 chemin = oFolderItem.Path
 Sheets("Liste Fichiers").Range("G1").Value = chemin & "\*." & extension

    'Adapter le chemin
   CheminSource = Cells(1, 7)

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

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

FichiersdansNdossiers

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
Dim extension 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

  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

Si quelqu'un a une idée.

Bonne journée

Il fallait travailler sur les extensions dans la partie RempliData

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