Liste de fichiers avec dossiers ET sous dossiers [Résolu/Fermé]

Signaler
-
Messages postés
37
Date d'inscription
mercredi 10 décembre 2014
Statut
Membre
Dernière intervention
6 octobre 2017
-
Bonjour à tous,

Je viens vous demander de l'aide car j'essaie depuis plusieurs semaines de créer un fichier Excel qui listerait tous les dossiers, sous-dossiers et fichiers d'un répertoire sur la même feuille de calcul.

J'ai fait des recherches et constaté que les macro sont utiles dans mon cas, car il y a plus de 5 000 fichiers dans le répertoire concerné. Cependant je n'ai pas trouvé de macro qui corresponde exactement à ce que je souhaite faire.

J'ai trouvé la macro suivante, qui permet d'afficher dans la première colonne le nom des fichiers et dossiers présentes dans le répertoire choisis et dans la deuxième colonne s'affiche le lien hypertexte (sous forme du chemin correspondant au fichier) pour ouvrir le fichier :

Sub lien_hypertext_liste_fichiers() 
' 
' lien_hypertext_liste_fichiers Macro 
' Macro enregistrée le 13/01/2007 par didus 
' 

Dim mess As String, mess2 As String, répertoire As String 
Columns(1).Clear 
Columns(2).Clear 
mess = InputBox("Chemin complet du répertoire à explorer, attention, / à la fin", "Chemin du répertoire", _ 
"Z:\Bibliotheque_Outillages\") 
mess2 = InputBox( _ 
"Donnez seulement le type de fichier (par exemple pdf, xls, doc, jpg ou dxf etc...)" _ 
, "TYPE DE FICHIER", "stl") 
Application.ScreenUpdating = False 
répertoire = Dir(mess & "*" & mess2, vbDirectory) 
Do While répertoire <> "" 
i = i + 1 
Cells(i, 1) = répertoire 
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=mess & répertoire 
Cells(i, 2) = mess & répertoire 
répertoire = Dir 
Loop 
End Sub


J'aimerais si possible garder à peu près ce code, avec les modifications pour pouvoir avoir également les fichiers qui sont à l'intérieur des sous-dossiers, l'arborescence complète en fait.

Je ne sais pas si j'ai été assez claire, mais merci d'avance de votre aide, je tiens à préciser que je connais pas grand chose des macros !

3 réponses

Messages postés
29730
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
12 octobre 2020
2 836
Bonjour,

Pour rechercher tous les fichiers/dossiers de chaque répertoire/sous-répertoire.. il faut faire du reccursif...

Par contre, voici un code qui fonctionne très bien.. qu'il ne te reste qu'à modifier pour qu'il corresponde exactement à tes besoins:
(je t'invite à le tester avant de nous répondre ^^ )

'----------------------------------------------------------------------------
'   Outils / Références A COCHER  Microsoft Scripting Runtime
'                                 Microssoft Shell Controls and Automation
'----------------------------------------------------------------------------
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim i As Long, k As Long
Dim oShell As Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim FSO As FileSystemObject, Dossier As Scripting.Folder, Fichier As Scripting.File
Dim Debut As Currency, Fin As Currency, Freq As Currency, NbDossiers As Long
Dim TypeFichier As String
 
Private Sub ExtractionDonnees(sDossier As String)
Dim LastRow As Long, j As Long
    Application.ScreenUpdating = False
 
    With Feuil1
        .Cells.Clear
        .Range("A1") = "Nom"
        .Range("B1") = "Taille"
        .Range("C1") = "Type"
        .Range("D1") = "Date Modification"
        .Range("E1") = "Date Création"
        .Range("F1") = "Date Dernier Accès"
        .Range("G1") = "Attributs"
        .Range("H1") = "Etat"
        .Range("I1") = "Propriétaire"
        .Range("J1") = "Auteur"
        .Range("K1") = "Titre"
        .Range("L1") = "Sujet"
        .Range("M1") = "Catégorie"
        .Range("N1") = "Pages"
        .Range("O1") = "Commentaires"
        .Range("P1") = "Copyright"
        .Range("Q1") = "Artiste"
        .Range("R1") = "Titre Album"
        .Range("S1") = "Année"
        .Range("T1") = "N° de Piste"
        .Range("U1") = "Genre"
        .Range("V1") = "Durée"
        .Range("W1") = "Vitesse Transmission"
        .Range("X1") = "Protégé"
        .Range("Y1") = "Modele Appareil Photo"
        .Range("Z1") = "Date Cliché"
        .Range("AA1") = "Dimension"
        .Range("AB1") = "Largeur"
        .Range("AC1") = "Hauteur"
        .Range("AD1") = "Nom Episode"
        .Range("AE1") = "Description Programme"
        .Range("AF1") = "Taille Echantillon Audio"
        .Range("AG1") = "Fréquence Echantillonnage"
        .Range("AH1") = "Chemin"
    End With
 
    k = 2
 
    Set oShell = New Shell
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(sDossier)
 
    NbDossiers = NbDossiers + 1
    For Each Fichier In Dossier.Files
        If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
            Set oFolder = oShell.Namespace(Dossier.Path)
            Set oFolderItem = oFolder.ParseName(Fichier.Name)
            i = 1
            With Feuil1
                For j = 0 To 34
                    If j <> 31 Then
                        .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                        i = i + 1
                    End If
                Next j
                .Range(NumCol2Lettre(i - 1) & k) = sDossier
                Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 1
                k = k + 1
            End With
        End If
    Next Fichier
 
    RchRecursive Dossier
    FormatAttributs
 
    With Feuil1
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:AH" & LastRow).WrapText = False
        .Range("1:1").Font.Bold = True
        .Rows("2:2").Select
        ActiveWindow.FreezePanes = True
 
        .Columns("A:AH").EntireColumn.AutoFit
        .Range("A1:AH1").Interior.ColorIndex = 36
        .Range("D2:F" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
        .Range("AF2:AF" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    End With
 
    Tri
 
    Feuil1.Activate
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    Set FSO = Nothing
    Set oShell = Nothing
    Set Dossier = Nothing
    Set oFolder = Nothing
    Set oFolderItem = Nothing
    Set Fichier = Nothing
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub FormatAttributs()
Dim LastRow As Long
    LastRow = Feuil1.Range("G" & Rows.Count).End(xlUp).Row + 1
    Feuil1.Range("G2:G" & LastRow).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function
 
Private Sub RchRecursive(sFolder As Scripting.Folder)
Dim SousDossier As Scripting.Folder
Dim j As Long
 
    For Each SousDossier In sFolder.SubFolders
        Set Dossier = FSO.GetFolder(SousDossier)
        NbDossiers = NbDossiers + 1
        For Each Fichier In SousDossier.Files
            If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
                Set oFolder = oShell.Namespace(Dossier.Path)
                Set oFolderItem = oFolder.ParseName(Fichier.Name)
                i = 1
                With Feuil1
                    For j = 0 To 34
                        If j <> 31 Then
                            .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                            i = i + 1
                        End If
                    Next j
                    .Range(NumCol2Lettre(i - 1) & k) = sFolder
                    k = k + 1
                End With
            End If
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k
        Next Fichier
 
        RchRecursive SousDossier
 
    Next SousDossier
End Sub
 
Sub SelDossier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            TypeFichier = InputBox( _
"Donnez seulement le type de fichier (par exemple pdf, xls, doc, jpg ou dxf etc...)" _
, "TYPE DE FICHIER", "stl")
            QueryPerformanceCounter Debut
            NbDossiers = 0
            ExtractionDonnees .SelectedItems(1)
 
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
 
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 2 & " / " & Format((Fin - Debut) / Freq, "0.00 s")
        End If
        Feuil1.Range("C1").Select
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    Feuil1.Range("A2:AH" & LastRow).Sort Key1:=Feuil1.Range("A2"), Order1:=xlAscending, Key2:=Feuil1.Range("B2") _
                                                                                              , Order2:=xlAscending, Key3:=Feuil1.Range("C2"), Order3:=xlAscending, Header:= _
                                         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                         DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                                         xlSortNormal
End Sub



Messages postés
37
Date d'inscription
mercredi 10 décembre 2014
Statut
Membre
Dernière intervention
6 octobre 2017
1
D'abord merci de la réponse,

Par contre comme je le disais je n'y connais rien en macro, et ce code est une nouvelle énigme pour moi ^^ Je suis tout à fait perdue, je ne sais pas ce que je dois modifier...

Voulez-vous bien m'éclairer s'il vous plaît ?

Merci bien.
Messages postés
1941
Date d'inscription
lundi 3 mai 2010
Statut
Membre
Dernière intervention
23 août 2020
138
Bonjour,

Apporter de la récursivité n'est pas trivial...
- Je n'ai pas l'impression que Excel soit nécessaire. En commande DOS, c'est assez simple : dir /b /s *.jpg > liste.txt
- Si c'est nécessaire, je conseille de d'abord créer l'arborescence de dossier (en t'inspirant de https://vbaforexcel.wordpress.com/2013/09/06/lister-les-fichiers-et-sous-dossiers-dun-dossier/ ) et utiliser la méthode de ta question pour chaque sous-dossier

A+
Messages postés
37
Date d'inscription
mercredi 10 décembre 2014
Statut
Membre
Dernière intervention
6 octobre 2017
1
Merci de la réponse.

J'ai essayé les codes qui sont proposés dans le lien que vous m'avez envoyé, cependant je n'ai pas l'impression que ceux-ci permettent de garder les liens hypertextes qui mènent aux fichiers du répertoire, ce que je souhaite absolument conserver.

Ce que je recherche est comme le code que j'ai montré, sauf qu'il afficherait tous les fichiers, du dossier 1 au dossier 5 par exemple, en imaginant que je place ce document Excel dans le dossier 1. Le lien hypertexte afficherait le chemin du fichier.

Merci tout de même de votre aide.
Messages postés
12185
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
21 septembre 2020
2 494
Bonjour,

Voir également cette discussion
Messages postés
37
Date d'inscription
mercredi 10 décembre 2014
Statut
Membre
Dernière intervention
6 octobre 2017
1
C'est exactement ce que je souhaitais !

Merci beaucoup de votre aide ^^