Liste de fichiers avec dossiers ET sous dossiers Résolu

Question

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 !

jordane45 · Answer

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

Zoul67 · Answer

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+

pijaku · Answer

Bonjour,

Voir également cette discussion

Liste de fichiers avec dossiers ET sous dossiers

3 réponses

Discussions similaires

Newsletters