Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 comment récupérer toute l'arborescence d'un dossier dans Excel ou Word

chantalou78

XLDnaute Nouveau
Bonjour
On me demande de faire l'arborescence des dossiers, sous dossiers et des fichiers... de mon service (j'en ai pour 100 ans !), afin que chacun puisse savoir ou trouver les informations

Je souhaiterais donc une aide pour récupérer l'arborescence du réseau sur lequel les dossiers sont classés et les "copier" dans un fichier Excel ou Word ...

Existerai t'il une solution plus rapide en VBA ou autre
- je suis sur office 2013
- je ne peux pas télécharger d'apk (pas les autorisations)
- Je n'ai pas la main pour faire /cmd (pas les autorisations)
- Je partirai de la racine de mon service pas du "C"
- récupération en format texte, Word, ou Excel
je continu à chercher

en vous remerciant par avance
cdt
 

patricktoulon

XLDnaute Barbatruc
Bonjour
@Dudu2 et moi avons travailler sur FSO(FilesystemObject) afin de le rendre plus rapide en récursif et de corriger les erreurs dues aux noms avec caracteres spéciaux, trop long,fichier system interdits d’accès,etc...)

je présente ici ma version qui permet de tout lister ou seulement les fichier ayant une partie de nom ou une extension particulière
a mettre dans un module
adapter le disque ou le chemin de dossier maitre
et lancer la la sub listeFSOGOSUB
VB:
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'-------------------------------------
'                          THEME
'recherche D 'amelioration  pour la lenteur de FSO en récursif
'recherche des moyens de controler les erreurs du aux noms trop long  ou fichiers interdit  ou system ou caracteres particuliers
'------------------------------------

'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$ = "*.*"
    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
 

patricktoulon

XLDnaute Barbatruc
Bonjour @BrunoM45
puisque la FSOte plait , la dir récursive devrait te plaire encore plus
je luis ai ajouté la correction des caractères spéciaux
et bien sur la fonction de transposition qui n'a pas de limite a l'inverse de la native

coller ceci dans un module
adapter la lettre du disque dans la ligne ( T = DirList("h:\") ', PartName:=extension))
et lancer la sub testDIR_1

même beepbeep ne va pas aussi vite
sauf bien évidement sur C qui est très lourd de dossiers et fichiers et au vues de tout ces dossier system et fichiers interdits qu'il contient mais meme là FSO fait pas le poids ( en liste complete )

par contre !!en liste fichier extention precise on peut avoir une égalité de puissance avec FSO
ça a été le but de ce travail avec @Dudu2 justement

par contre aussi avec la dir les fichier erreur 52,53,72 sont quand même récupérés et identifiés comme fichier et leur noms est corrigé

VB:
'**********************************************************
'                fonction récursive pour dir vba
'utilisation de Dir VBA
'auteur: patricktoulon Sur DVP et Exceldownloads
'date:09/11/2016
'
'mises a jour
'date:03/15/2018: utilisation d'une collection pour le stockage provisoire des dossiers
'date 07/02/2021:désormais la fonction compile l'array a la fin de l'appel #1 de la fonction (recall=false)
'date 07/02/2021: ajout de l'argument "PartName"
'date 08/02/2021: ajout d'une fonction de transposition simple pour eviter la limite de la fonction transpose de vba pour 2007 et ceux qui n'on pas installé le KB complement de correction du LAA pour 2013 2010 version disque
'date 09/02/2021: ajout de la gestion d'erreur et correction sur les fichiers portant un nom avec des caracteres spéciaux
'                ainsi que les dossiers ou fichiers interdits
'*************************************************************
Option Explicit

Function TransposeArray2(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
    TransposeArray2 = tbl
End Function


Sub testDIR_1()
    Dim tim#, T, extension$
    [A1].CurrentRegion.Clear
    extension = "*.*"
    tim = Timer
    T = DirList("h:\") ', PartName:=extension)

    If IsArray(T) Then
        MsgBox Timer - tim & " secondes pour " & UBound(T) & " fichier(s)"
        [A1].Resize(UBound(T)) = TransposeArray2(T)
    Else
        MsgBox "pas de fichier"
    End If

End Sub
Function DirList(Dossier As String, Optional Recall As Boolean = False, Optional PartName As String = "") As Variant
    Dim ItemVu As String, SubFolderCollection As New Collection, I As Long, a As Long, q As Long, criteres, arr1, arr2, subdossier, x
    Static tbl$()    'tbl est statique
    arr1 = Array("a~", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨")    'array caracteres séparés
    arr2 = Array("ã", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü")    'array caracteres regroupés
    If Recall = False Then ReDim tbl(0)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    criteres = vbDirectory Or vbSystem Or vbHidden Or vbArchive Or vbReadOnly Or vbNormal
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, criteres)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do While ItemVu <> vbNullString    'boucle tant que DIR renvoie une chaine
            If ItemVu <> "." And ItemVu <> ".." And Not ItemVu Like "*RECYCLE*" Then
                On Error Resume Next
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then    'test Dossier
                    If Err.Number > 0 Then    'si erreur c'est un fichier(particulier ou caracteres particulier)
                        If Err.Number = 53 Then    'si c'est des caracteres bizarres
                            For q = 0 To UBound(arr1): ItemVu = Replace(Replace(ItemVu, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next  'replace caracteres
                            If PartName <> "" Then
                                If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            Else
                                ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            End If
                        Else
                            'si autre erreur
                            'If PartName <> "" Then
                                'If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & dossier & ItemVu
                            'Else
                                ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            'End If
                        End If
                        'si dossier
                    Else
                        SubFolderCollection.Add Dossier & ItemVu    'sinon ajout dans la collection de dossier
                    End If
                    Err.Clear
                Else    'sinon c'est un fichier et pas un concombre:)

                    'If ItemVu Like PartName Then
                    If PartName <> "" Then
                        If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
                    Else
                        ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
                    End If
                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear    'si erreur a la racine du dir actuel
    End If
    'examen des sub dossier appel récursif
    For Each subdossier In SubFolderCollection
        DirList subdossier & "\", True, PartName
    Next subdossier
    DirList = False
    If Not Recall Then DirList = tbl  ' return du tableau (apres le dernier appel récursif )'economie de 0.3000 secondes
End Function

ça boust!!!!
 

Etoto

XLDnaute Barbatruc
On me demande de faire l'arborescence des dossiers, sous dossiers et des fichiers... de mon service (j'en ai pour 100 ans !), afin que chacun puisse savoir ou trouver les informations
Hello à tous,

Power Query fait cela, grâce à ça j'ai eu un tableau de 94'000 lignes avec l'arborescence de chaque fichier et le nom de l'extension avec le chemin et les sous dossiers avec "Nouvelle requête/à partir d'un fichier/à partir d'un dossier."
 

patricktoulon

XLDnaute Barbatruc
moi je l'ai installé mais il y a des fenetre et autres que vous avez que je n'ai pas
ce qui fait que si je veux le faire par PWQ je suis un peu coincé
par contre si tu me livre un fichier 2016 avec la requete PWQ je peux l'ouvrir et bénéficier du résultat de la requête à moins que là encore il y ai des choses que je n'ai pas
par contre je ne peux pas la modifier (tout du moins dans certains cas)car je n'ai pas tout les interfaces que vous avez sur 2016 et plus
 

Etoto

XLDnaute Barbatruc
Ha ouais ! Plus de problèmes de compatibilité donc, alors même si je tente de lui envoyer une requête exemple avec PWQ cela va même pas l'aider pour 2013 vu que je suis en 2016, c'est stupide !! Quand j'ai vu qu'il parlait d'Excel 2013, je ne pensais pas que y'avait autant de différence entre 2013 et2016 pour PQW.

Bonne chance alors pour ton VBA Patrick parce que je suis visiblement inutile sauf si j'achète Excel 2013 mais ce serai bête vu que j'ai le 2016.
 

patricktoulon

XLDnaute Barbatruc
re
d'ailleurs ils ont arrêté de développer PWQ pour 2013
sur MS.com il n'est même plus dipo je crois
car il y a bien trop de différences
il est certains que de plus en plus certains s'oriente vers PWQ et ceux qui ne l'ont pas seront handicapés
mais je lache rien perso je l'utilise pas PWQ
déjà j'estime 2013 est très lourd en ressource je l'ai pris pour avoir des choses en plus qui aujourd'hui sont indispensables dans les échanges )
mais alors 2016 et plus c'est le ponpon
après 2007 excel est devenu une suite en lui meme dans la suite OFFICE ( des patchs a gogo ,etc...) et sur des petits PC (portable et autres ) on le constate bien )
 

Etoto

XLDnaute Barbatruc
il est certains que de plus en plus certains s'oriente vers PWQ et ceux qui ne l'ont pas seront handicapés
mais je lache rien perso je l'utilise pas PWQ
Oui j'ai remarqué que Microsoft essaie de remplacer le VBA petit à petit, notamment avec PWQ.
mais je lache rien perso je l'utilise pas PWQ
Tu es un survivant !!
déjà j'estime 2013 est très lourd en ressource je l'ai pris pour avoir des choses en plus qui aujourd'hui sont indispensables dans les échanges )
mais alors 2016 et plus c'est le ponpon
Ha tu trouves ? Perso cela me dérange pas.
après 2007 excel est devenu une suite en lui meme dans la suite OFFICE ( des patchs a gogo ,etc...) et sur des petits PC (portable et autres ) on le constate bien )
Ok, la suite office est née après Excel 2007, intéressant, tu m'apprends plein de trucs quand on est dans un même fil.
 

patricktoulon

XLDnaute Barbatruc
re
non c'est pas la suite office qui est née après 2007
c'est excel tout court qui est devenu une suite
disons que c'est ma vision de l'app excel 2016
je parle même pas de 365
toi ça te dérange pas parce que tu n'a peut être pas connu excel 2000/2003 et plus tard 2007
j'ai meme travailler sur excel 97 c'est pour te dire
car si tu avais travaillé sur ces versions pendant des années je te jure que tu aurais les cheveux qui se dressent sur la tète a voir la lourd esse des versions d'office aujourd'hui
bref c'est pas le sujet je m’égare notre amis a les deux possibilité VBA
il a ce qu'il faut
 

Etoto

XLDnaute Barbatruc
toi ça te dérange pas parce que tu n'a peut être pas connu excel 2000/2003 et plus tard 2007
j'ai meme travailler sur excel 97 c'est pour te dire
Alors c'est simple :

Multiplan : Pas né
Excel : Pas né
Excel 2.0 : Pas né
Excel 95 : Pas né
Excel 97 : Pas né
Excel 2003 : Pas né
Excel 2007 : Jamais fait
Excel 2013 : Bosser dessus à l'école
Excel 2016 : Mon Excel personnel et professionnel
Excel 2019 : J'ai hésité à l'acheter
Microsoft 365 : Je l'ai aux cours et j'hésite a l'acheter.

Je suis jeune hein ??
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…