XL 2016 lire des sous-dossiers ou fso

'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'Auteurs Dudu2 et patricktoulon  sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel

'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc  <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumpé directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier

'Date:25/04/2021
'ajout de la gestion d'appels récursifs (on le décide au départ )
'la fonction a donc un argument en plus
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
Function TransposeArray(arr)    ' fonction de transposition pour palier au limites de la fonction transpose d'excel
    Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
    For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
    TransposeArray = tbl
End Function
'
Sub listeFSOGOSUB()
    Dim Table As Variant, tim, Répertoire, Intresult
    Dim REPSOMMAIRE As Object, cheminsommaire$
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        Intresult = .Show
        If Intresult <> 0 Then Répertoire = .SelectedItems(1) & "\" Else Exit Sub
    End With
    tim = Timer
    Const Ext$ = "*"        'exemple de recherche de tout fichiers
    'Const Ext$ = "*.txt"        'exemple de recherche de tout fichiers avec extension précise
    'Const Ext$ = "*toto.txt"    'exemple de recherche de tout fichier ayant la fin du nom
    'Const Ext$ = "toto*.txt"    'exemple de recherche de tout fichier ayant pour début du nom
    'Const Ext$ = "*toto*.txt"   'exemple de recherche de tout fichier ayant une partie  du nom
    Appelcount = 0    '
    countdoss = 0

    'Table = FSO_List_FICHIERS2(Répertoire, Ext)    ' exemple d'appel non recursif et sans les noms de dossier
    'Table = FSO_List_FICHIERS2(Répertoire, Ext, True)    ' exemple d'appel  recursif et sans les noms de dossier
    Table = FSO_List_FICHIERS2(Répertoire, Ext, True, True)    ' exemple d'appel non recursif avec  les noms de dossier

    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier/dossiers(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
               vbCrLf & "pour " & Appelcount & " appels de la fonction dans dossier et sous dossier" & vbCrLf & countdoss & " dossiers utilement explorés"

        ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table

    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant  " & Ext
    End If
End Sub

Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "", Optional recursif As Boolean = False, Optional WithFolder As Boolean = False) As Variant
    Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
    Appelcount = Appelcount + 1
    countdoss = countdoss + 1
    Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean

    If TypeOf Folder Is Object  Then                            'si ce nest pas le premier appel  Foler est un objet folder membre de FSO
        First_Call = False                                      'si ce nest pas le premier appel  on positionne First_Call a false des les 2d appel
        Set oDir = Folder                                       'si ce nest pas le premier appel  Odir est donc un object Folder membre de FSO
    Else                                                        'si c'est le premier appel Folder est de type string
        First_Call = True                                       'si c'est le premier appel first_call est a true
        Erase tbl                                               'si c'est le premier appel on eraze la variable tableau  <<tbl>>
        NbFichiers = 0                                          'si c'est le premier appel on met la variables NbFichiers à 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")   'si c'est le premier appel on créée l'object FSO
        If Right(Folder, 1) <> "\" Then Folder = Folder & "\"   'si c'est le premier appel si le slach de fin on l'ajoute
        Set oDir = oFSO.getfolder(Folder)                       'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
    End If

    TakeIT = True                                               'on met la variable Takeit à true d'office
    ' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
    'la gestion est valable aussi pour la boucle subFolder elle est fermé a chaque fin d'appels récursifs
    On Error Resume Next
    If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0    'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
    If recursif = False Then TakeIT = True    ' si pas d'apel récursif on met takeit a true d'office  pour scruter les fichier enfant direct
    If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder    ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub

    If recursif Then If WithFolder Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oDir.Path

    For Each oFile In oDir.Files            'boucle sur les fichiers
        If Err.Number = 0 Then              'si pas d'erreur
            If Len(PartName) = 0 Then       'si pas de PartName demandé on memorise le fichier directement
                NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
            Else                            'si PartName demandé on teste si le nom de fichier like PartName
                If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path                'Stocke le nom complet du fichier en table
            End If
        End If
        Err.Clear                                       ' on clear l'erreur au cas ou
    Next oFile

Scanfolder:        ' etiquette du jumping d'exploration
    If recursif Then
        For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
            ' If recursif = False Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oSubDir.Path
            If Err.Number = 0 Then
                FSO_List_FICHIERS2 oSubDir, PartName, recursif, WithFolder      ' on relance la fonction ( appel récursif)
            Else: Err.Clear                                 ' sinon on clear l'erreur si dossier interdit ou special
            End If
        Next oSubDir
        On Error GoTo 0                                     ' ferme la gestion d'erreur globale
    End If
    ' si c'est le premier appel  donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
    If First_Call Then
        FSO_List_FICHIERS2 = False                      ' on met le return de la fonction a false
        If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl    ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
    End If

End Function