Lister un repertoire et les sous repertoires

[jmsonnet]

Bonjour
j'utilise cettemacro pour lister et je n'arrive pas à lister les sous repertoire je ne voie que le contenu du dossier mis dans chemin et pas le contenu des sous repertoires qui peux me dire ou je me suis plante merci.

Private Sub CommandButton12_Click()
Dim dossier As Object, subfolder As Object, fichier As Object

Dim chemin As String

Dim i As Long
Dim ch As String

Sheets("feuil2").Select
Range("A6:B643").clear
Range("D6:E643").clear

chemin = "C:\Documents and Settings\jeanmimi\Bureau\MBR\Suivi-BT-HV\"

'Définition de la variable
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
'Set fso_objet = dossier.CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
' Boucle sur les fichiers
For Each fichier In dossier.Files
i = i + 1

'Cells(I, 2) = Fichier.Name ' Nom du fichier
Range("A6").Cells(i, 2) = Left(fichier.Name, InStr(fichier.Name, ".") - 1) 'sans l'extension
Range("A6").Cells(i, 4) = fichier.DateCreated ' Date de création
Range("A6").Cells(i, 5) = fichier.DateLastModified ' Nom du fichier
Range("A6").Cells(i, 10) = fichier.ParentFolder.Name ' Nom du fichier
Next

Unload Gestion_des_BT
Sheets("Feuil2").Visible = True
Range("A1").Select
End Sub

 

[JNP]

Re : Lister un repertoire et les sous repertoires

Bonjour JMSonnet ,

For Each sousdossier In dossier.SubFolders
MsgBox sousdossier.Name
Next

te donnera le nom des sousdossier. Après, il te faut faire une fonction récursive pour exploiter tous les dossiers et sous-dossiers.
Bon courage

 

[CBernardT]

Re : Lister un repertoire et les sous repertoires

Bonjour jmsonnet, JNP et le forum,

Le fichier joint permet d'afficher tous les fichiers présents dans les sous répertoires d'un répertoire.

 

[jmsonnet]

Re : Lister un repertoire et les sous repertoires

Bonjour jmsonnet, JNP et le forum,

Le fichier joint permet d'afficher tous les fichiers présents dans les sous répertoires d'un répertoire.

bonjour #2 (permalink)

juste une question je suis debutant en vba et je ne sais pas comment on fait une fonction récursive pour exploiter tous les dossiers et sous-dossiers.
ni ou la placer dans mon mis dans le 1° message merci de m'aider

 

[JNP]

Re : Lister un repertoire et les sous repertoires

Re

juste une question je suis debutant en vba et je ne sais pas comment on fait une fonction récursive pour exploiter tous les dossiers et sous-dossiers.

Je ne suis pas vraiment débutant en VBA, mais les fonctions récursives, c'est une autre histoire ...
La théorie, c'est de faire une fonction qui s'appelle elle-même afin de faire tous les noeuds de ton arborescence.
De la théorie à la pratique, il y a un grand pas .
J'ai retroussé mes manches et codé ma première fonction récursive .

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Documents and Settings\jeanmimi\Bureau\MBR\Suivi-BT-HV\"
I = 1
Application.ScreenUpdating = False
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
ListeFichier (Chemin & SousDossier.Name & "\")
Next
Next
End Function

qui colle en A le nom du dossier et en B le nom du fichier.
Attention, elle ne tient pas compte des fichiers dans le premier dossier.
Tu réadapteras aux infos que tu souhaites et l'emplacement où tu écris .
Attention juste à ne pas dépasser le nombre de ligne d'Excel, j'ai fait un test sur 80 000 lignes sous 2010, comme tu es sous 2007, tu n'es pas limité à 65 536 lignes, à condition d'enregistrer en format XLSM et pas en XLS (qui pour rester compatible, limite le nombre de lignes).
Bon courage

 

[MJ13]

Re : Lister un repertoire et les sous repertoires

Bonjour à tous

Sinon, extrait de mon utilitaire :

Sub TousLesDossiers(LeDossier$, IDX As Long)
'Frederic Sigonneau
IDX = Range("A65536").End(xlUp).Rows.Row
    Dim fso As Object, Dossier As Object
    Dim sousRep As Object, Flder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
 
    'Set Dossier = USF_Options_Excel!TB_DD
    'MsgBox Dossier
    'MsgBox LeDossier
    'IDX = IDX + 1
    'examen du dossier courant
    'Cells(IDX, 1).Value = LeDossier
    'Stop
    For Each Flder In Dossier.subfolders
        IDX = IDX + 1
        Cells(IDX, 1).Value = Flder.Path
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(IDX, 2), Address:= _
        Flder.Path
    Next
    'Stop
    'traitement récursif des sous dossiers
    For Each sousRep In Dossier.subfolders
        TousLesDossiers sousRep.Path, IDX
    Next sousRep
    Set fso = Nothing
End Sub

Ah Jean-Noël: Bravo pour ta première fonction récurcive, si cela fonctionne c'est super . Je testerai plus tard .

 

[papapaul]

Re : Lister un repertoire et les sous repertoires

Bonjour Forum,
Pour ma part, j'ai trouvé ca, fichier joint.
Moins joli et surtout beaucoup plus compliqué
que celui de CBernardT mais qui si je ne me trompe
permet de lister aussi directement de sous la racine C:\ ou
par exemple E:\ Les deux fichiers sont trés bien.

Dans celui que je joins, j'aurai voulu associer un chronomètre en A1
qui ce déclenche au click sur le bouton LoadFichiers et qui s'arrête
quand la recherche et l'écriture sur la feuille se termine.
Je joins aussi un fichier "chronomètre" trouvé sur le forum
mais que je sais pas intégrer dans l'outil de recherche des fichiers.

Merci d'avance

Lien supprimé

 

[JNP]

Re : Lister un repertoire et les sous repertoires

Re ,

Ah Jean-Noël: Bravo pour ta première fonction récurcive, si cela fonctionne c'est super . Je testerai plus tard .

Merci Michel. Oui, elle fonctionne . Et si ça t'interresse, la voici avec les fichiers du dossier "maître" (je ne l'avais pas mis, vu que notre ami savait déjà extraire ces fichiers là !).

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Users\JNP\Documents\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
Cells(I, 1) = Dossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
[COLOR=seagreen]ListeFichier (Chemin & SousDossier.Name & "\")[/COLOR]
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
Next
End Function

Pour ma part, j'ai trouvé ca, fichier joint.
Moins joli et surtout beaucoup plus compliqué
que celui de CBernardT mais qui si je ne me trompe
permet de lister aussi directement de sous la racine C:\ ou
par exemple E:\ Les deux fichiers sont trés bien.

J'ai essayé de les tester. C'est vrai que ça parait assez usine à gaz , mais comme il y a des appels à DLL, ça ne fonctionne pas chez moi, ceux-ci ayant changé avec le 64 bit . Je ne pourrai donc pas intégrer ton chrono...
Bon dimanche
Ajout : Une erreur s'était glissée dans le positionnement d'une ligne. La ligne en vert a été repositionnée au bon endroit. Désolé pour ceux qui ont obtenus des résultats éronnés.

 

[jmsonnet]

Re : Lister un repertoire et les sous repertoires

Merci pour vos reponses c'est vrai que le fichier de CBernardT est exelant mais juste un point comment enlever l'extension : .doc ou .xls au nom.

 

[CBernardT]

Re : Lister un repertoire et les sous repertoires

re,

Une petite modif afin de supprimer les extensions des noms des fichiers.

 

[jmsonnet]

Re : Lister un repertoire et les sous repertoires

super ca marche mais juste une derniere question si je veux incorporer ta macro dans un userform en fixant le repertoire a rechercher ?

 

[waow29]

Bonjour!
Je reviens sur le sujet car il m'interesse enormement.
Quelqu'un aurait il les competences pour faire un mix des 2 fichiers cités plus haut.
C'est à dire garder la structure du fichier "FichiersDansRepSousRepV1" en y ajoutant une colonne entre les noms des fichiers et la date, dans cette colonne seraient les liens hypertextes comme dans le fichier "Lister les fichiers dans Excel"???
Ca serait super de m'aider!! Merci

 

[MJ13]

Re : Lister un repertoire et les sous repertoires

Bonjour WAow, à tous

Waow: Sympa le code, Essaye comme ceci :

Option Explicit
Public Chemin As String, I As Long
Sub RepFichiers()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
On Error GoTo 0
If Chemin = "" Then Exit Sub
Application.ScreenUpdating = False
With Sheets("ACCUEIL")
.Range("B12") = Chemin
.Range("B16:E10000").ClearContents
End With
I = 16
ListeFichier (Chemin)
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
With Sheets("ACCUEIL")
For Each SousDossier In Dossier.SubFolders
    .Cells(I, 2) = SousDossier.Name
    For Each Fichier In SousDossier.Files
    .Cells(I, 3) = Left(Fichier.Name, InStr(Fichier.Name, ".") - 1) 'Nom du fichier avec l'extension
    .Cells(I, 4) = Dossier & "\" & SousDossier & "\" & Fichier.Name
       
    .Cells(I, 5) = Fichier.DateCreated  ' Date de création
    .Cells(I, 6) = Fichier.DateLastModified  ' dernière modification
ActiveSheet.Hyperlinks.Add Anchor:=Cells(I, 4), Address:=SousDossier & "\" & Fichier.Name
    I = I + 1
     Next
Next
End With
End Function

 

[CBernardT]

Re : Lister un repertoire et les sous repertoires

Bonjour à tous,

Reprise de l'excellent code de MJ13.

Le lien hypertexte est directement créé sur le nom du fichier.

 

[kiki29]

Re : Lister un repertoire et les sous repertoires

Salut à tous, voir #15 entre autres sur https://www.excel-downloads.com/threads/vba-liste-dossiers-et-sous-dossiers-dun-dosssier.126930/