XL 2019 Lister un répertoire pour extraire un sommaire

netparty

XLDnaute Occasionnel
Bonjour à tous

Je me demande si il es possible de scanner un répertoire sélectionné et de sortir un listing style sommaire qui reprend tout les noms de répertoire, sous-répertoire et nom des fichiers.

VB:
Exemple de répertoire à lister

Répertoire principale
---    Sous-répertoire 1
    ---    Fichier.pdf
    ---    Fichier.doc
---    Sous-répertoire2
    ---Fichier.pdf
    ---    Fichier.doc
----Sous-répertoire3
    ---Fichier.pdf
    ---Fichier.doc
Fichier.pdf

*********************************

Sommaire

Répertoire principale
Sous-répertoire 1
Fichier.pdf
Fichier.doc
Sous-répertoire2
Fichier.pdf
Fichier.doc
Sous-répertoire3
Fichier.pdf
Fichier.doc
Fichier.pdf

Bonne journée
 
Solution
re
si ca n'est que ca
VB:
'VERSION MODIFIEE POUR <<"netparty sur ExcelDownload >>"

'**************************************************************
'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...

patricktoulon

XLDnaute Barbatruc
Bonjour
@Dudu2 et moi avons travaillé sur l'object FSO et ça célèbre lenteur dans une fonction récursive
et effectivement contrairement a ce que l'on croyait depuis fort longtemps le problème ne viens pas de lui en effet si on le pilote de manière pratique et intelligente on obtient des résultat surprenant de rapidité comparé a (dir dans une fonction récursive)
a savoir quand lister ou pas
ça se remarque d'autant plus dans l'exemple qui va suivre lorsqu'on cherche une extension de fichier en particulier
on a aussi limité le gonflage mémoire en compilant uniquement lorsque la récursivité a fini et que l'on est donc dans la boucle récursive au niveau du premier appel

modifier la constante répertoire pour adapter le chemin de ton dossier
pour les tests nous avons testé a chaque fois sur un disque entier et deja les résultats sont plus que satisfaisants

VB:
'**************************************************************
'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 jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
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
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "h:\": tim = Timer
    Const Ext$ = "*" 'mettre ici l'extention de fichier que vous cherchez
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(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 = "") 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 es 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 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


    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

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
        
            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' 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

' 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

sur le disque C qui dure des plombes normalement (normal c'est le disque system)
quand on cherche par exemple les fichiers "*.txt"
la fonction reviens a 160 secondes environ avant ca durait plus de 6 minutes
et les fichiers sont bien listés il n'en manque pas
1619075268738.png
 
Dernière édition:

netparty

XLDnaute Occasionnel
re c'est dans le domaine du possible oui
cela dit des simple nom tu n'a plus l'arborescence apres pour te servir des nom apres dans une macro ou fonction c'est rapé
En fait je voudrais juste récupérer les nom pour créer un sommaire.

Pour mes projets, le crée un dossier dans le quel je classe par dossier toutes une série de documents.
Ensuite je crée manuellement un sommaire ou j"écris le nom du dossier comme titre et son contenu les nom de fichiers.

C'est pour cela que je n'ai pas besoin des chemins.

Merci à toi

Bonne soirée
 

patricktoulon

XLDnaute Barbatruc
tiens teste celle ci

j'ai mis "D_" devant les noms de dossier et " F_" devant les noms de fichier

VB:
'VERSION MODIFIEE POUR <<"netparty sur ExcelDownload >>"

'**************************************************************
'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 jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
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
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "h:\": tim = Timer
    Const Ext$ = "*.txt" 'mettre ici l'extention de fichier que vous cherchez
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(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 = "") 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 es 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 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

   NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "D_" & oDir.Name
         
    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) = "   F_ " & oFile.Name
            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) = "   F_ " & oFile.Name               '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

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
       
            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' 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

' 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
 

netparty

XLDnaute Occasionnel
Bonjour patricktoulon

Est-il possible d'avoir une fenêtre qui s'ouvre pour le choix du répertoire.

Merci

tiens teste celle ci

j'ai mis "D_" devant les noms de dossier et " F_" devant les noms de fichier

VB:
'VERSION MODIFIEE POUR <<"netparty sur ExcelDownload >>"

'**************************************************************
'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 jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
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
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "h:\": tim = Timer
    Const Ext$ = "*.txt" 'mettre ici l'extention de fichier que vous cherchez
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(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 = "") 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 es 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 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

   NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "D_" & oDir.Name
        
    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) = "   F_ " & oFile.Name
            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) = "   F_ " & oFile.Name               '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

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
      
            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' 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

' 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
 

netparty

XLDnaute Occasionnel
Bonjour
si tu fait une recherche de folderdialog tu trouvera c'est de niveau débutant ça tu devrais t'en sortir
c'est une forum d'entraide pas une source de tout cuit
Bonjour patricktoulon

J'ai adapté le code, j'arrive a ouvrir la boite de dialogue, mais j'ai une erreur j'ai l'impression qu'il ne stock pas le nom du répertoire
Voila le bout de code que j'ai modifier :
VB:
Sub listeFSOGOSUB()
    Dim Table As Variant, tim
    Dim REPSOMMAIRE As Object, cheminsommaire$
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Set REPSOMMAIRE = Application.FileDialog(msoFileDialogFolderPicker)
    REPSOMMAIRE.Show
    cheminsommaire = REPSOMMAIRE.SelectedItems(1) & "\"
    Const Répertoire = "cheminsommaire": tim = Timer

Suis-je sur la bonne voie ?

Merci
 

patricktoulon

XLDnaute Barbatruc
re
Bonsoir
comme tu a pris la peine de chercher je corrige
une constante ne doit pas recevoir une variable il faut la modifier en variable

la constante répertoire est donc devenu une variable variant

VB:
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
  'on continu le code '
 

netparty

XLDnaute Occasionnel
Bonjour patricktoulon

Merci pour retour sur le code.

J'ai encore une petite question, si j'ai un répertoire vide alors je n'ai pas ce répertoire dans mon tableau y a t-il la possibilité d'afficher même si il y a des répertoire vide.

Merci d'avance
bonne journée
 

patricktoulon

XLDnaute Barbatruc
re
bonjour
il suffisait de déplacer une ligne
VB:
'VERSION MODIFIEE POUR <<"netparty sur ExcelDownload >>"

'**************************************************************
'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 jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
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$ = "*" 'mettre ici l'extention de fichier que vous cherchez
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(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 = "") 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 es 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 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
  
        
    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) = "   F_ " & oFile.Name
            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) = "   F_ " & oFile.Name               '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

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
        NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "D_" & oSubDir.Name

            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' 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

' 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
 

Discussions similaires

Réponses
19
Affichages
2 K

Statistiques des forums

Discussions
311 729
Messages
2 081 971
Membres
101 852
dernier inscrit
dthi16088