Macro pour lister des fichiers présent dans un dossier choisie

Bonjour

J'ai actuellement une macro qui me permet de selectionner un fichier txt

Mais je souhaiterais savoir si il y a une solution qui permettrais de selectionner un dossier et de lister tout les fichiers présent

Exemple

En selectionnant le dossier OP300_R1 je souhaiterais lister tout les fichiers .txt qui se trouvent dans les sous dossiers

Merci

Je reste à votre disposition pour tout renseignement complémentaire

Bonjour,

A adapter :

Option Explicit

Public IndexListe As Integer
Public Fso As Object
Public Liste_Fichiers  As Variant

Sub LancerListerLesFichiers()

    ListerLesFichiers "D:\Documents\......\" 'A adapter

End Sub

Sub ListerLesFichiers(ByVal Repertoire As String)

Dim I As Long, DerniereLigne As Long
Dim AireFichiers As Range
Dim ShFichiers As Worksheet

    Application.ScreenUpdating = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    IndexListe = 0
    ReDim Liste_Fichiers(3, IndexListe)
    Set ShFichiers = Sheets.Add(after:=Sheets(Sheets.Count))

    ListeRecursive Fso.GetFolder(Repertoire)

    If IndexListe Then
       For IndexListe = LBound(Liste_Fichiers, 2) To UBound(Liste_Fichiers, 2)
           With ShFichiers
                .Cells(IndexListe + 2, 1) = Liste_Fichiers(0, IndexListe)
                .Cells(IndexListe + 2, 2) = Liste_Fichiers(1, IndexListe)
                .Cells(IndexListe + 2, 4) = Liste_Fichiers(2, IndexListe)
                .Cells(IndexListe + 2, 5) = Liste_Fichiers(3, IndexListe)
            End With
       Next IndexListe
    End If

    With ShFichiers
         .Range("A1:E1") = Array("Fichier", "Répertoire", "Lien", "Dernière modification", "Date création")
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireFichiers = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))

        If IndexListe > 0 Then
           ReconstituerLesLiensHypertextes ShFichiers, AireFichiers
        End If

        .Activate
        .Columns("A:A").EntireColumn.AutoFit
        With .Columns("C:E")
             .EntireColumn.AutoFit
             .HorizontalAlignment = xlCenter
        End With
    End With

    Set Fso = Nothing
    Set ShFichiers = Nothing

    Application.ScreenUpdating = True

    MsgBox "Fin de recherche !", vbInformation

End Sub

Sub ListeRecursive(ByVal f As Object)

Dim Sf As Object, Fich As Object, Sf2 As Object

        For Each Fich In Fso.GetFolder(f).Files
            If Fso.GetExtensionName(Fich) = "txt" Then
                ReDim Preserve Liste_Fichiers(3, IndexListe)
                Liste_Fichiers(0, IndexListe) = Fich.Name
                Liste_Fichiers(1, IndexListe) = Fich.Path
                Liste_Fichiers(2, IndexListe) = Fich.DateLastModified
                Liste_Fichiers(3, IndexListe) = Fich.DateCreated
                IndexListe = IndexListe + 1
            End If
        Next Fich

    For Each Sf In f.SubFolders
        For Each Fich In Fso.GetFolder(Sf).Files
            If Fso.GetExtensionName(Fich) = "txt" Then
                ReDim Preserve Liste_Fichiers(3, IndexListe)
                Liste_Fichiers(0, IndexListe) = Fich.Name
                Liste_Fichiers(1, IndexListe) = Fich.Path
                Liste_Fichiers(2, IndexListe) = Fich.DateLastModified
                Liste_Fichiers(3, IndexListe) = Fich.DateCreated
                IndexListe = IndexListe + 1
            End If
        Next Fich
        ListeRecursive Fso.GetFolder(Sf)
    Next Sf

End Sub

Sub ReconstituerLesLiensHypertextes(ByVal ShFichiers2 As Worksheet, ByVal AireFichiers2 As Range)

Dim I As Long, IndexLien As Long

    IndexLien = 1
    For I = 1 To AireFichiers2.Count
        With AireFichiers2(I)
             If .Value <> "" Then
                .Hyperlinks.Delete
                ShFichiers2.Hyperlinks.Add Anchor:=AireFichiers2(I).Offset(0, 2), Address:=AireFichiers2(I).Offset(0, 1), TextToDisplay:=CStr(IndexLien)
                IndexLien = IndexLien + 1
            End If
        End With
    Next I

End Sub

Bonsoir à tous,

Une proposition via Power Query (Chemin du répertoire parent dans une cellule nommée "CheminDossier") :

let
    Source = Folder.Files(Excel.CurrentWorkbook(){[Name="CheminDossier"]}[Content]{0}[Column1]),
    #"Lignes filtrées" = Table.SelectRows(Source, each (Text.Lower([Extension]) = ".txt")),
    #"Autres colonnes supprimées" = Table.SelectColumns(#"Lignes filtrées",{"Name", "Folder Path"})
in
    #"Autres colonnes supprimées"

EDIT : Visiblement.... en retard !

EDIT 2 : Non..... je dois être en avance de quelques millisecondes ....

Bonjour,
Un lien pour lister les fichiers d'un répertoire avec Power Query.
Il faudra réaliser un filtre sur les extensions de fichiers (txt ?).
Cdlt.

lien : Liste fichiers répertoire

Vous êtes vraiment super

J'ai pris la solution d'Eric Kergresse

Maintenant je dois réussir à le combiner à l'autre macro

Bonsoir de nouveau,

Je vous remercie de ce retour.

Et.... bon codage !

Arh

Actuellement dans ma macro j'ai ça

Fichiertxt = Application.GetOpenFilename(filefilter:=" Fichiers texte,*.txt", MultiSelect:=True)

mais cela ne me permet pas de juste selectionner un dossier pour faire varier automatiquement ListerLesFichiers

Sub LancerListerLesFichiers()

    ListerLesFichiers "D:\OP300_R1\" 'A adapter

End Sub

Quand je lance ma macro je souhaiterais qu'une fenetre s'ouvre et que je puisse juste selectionner un dossier et non un fichier (que j'ai juste a selectionner le dossier OP330_R1)

Modifiez la procédure LancerListerLesFichiers et ajoutez la fonction RepertoireChoisi.

Sub LancerListerLesFichiers()

Dim RepertoireEnCours As Variant

    RepertoireEnCours = RepertoireChoisi
    If RepertoireEnCours <> "" Then
       ListerLesFichiers RepertoireEnCours & "\"
    End If

End Sub

Function RepertoireChoisi() As Variant

Dim Fd As FileDialog
Dim RepertoireSelectionne As Variant

    RepertoireChoisi = ""
    Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
    With Fd
        If .Show = -1 Then
            For Each RepertoireSelectionne In .SelectedItems
                RepertoireChoisi = RepertoireSelectionne
            Next RepertoireSelectionne
        End If
    End With
    Set Fd = Nothing

End Function

Merci beaucoup désolé pour le temps de réponse