Extraire la liste des sous-dossiers d'un dossier
Bonjour,
Je souhaite extraire la liste des sous dossiers contenus dans un dossier.
J'ai trouvé le code de Silkyroad ci-dessous qui répond partiellement à mes besoins.
Celui-ci fonctionne parfaitement cependant je souhaiterais :
1- N'extraire que le premier niveau de sous-dossier de ce dossier (je ne veux pas récupérer les sous-dossiers des sous-dossiers).
2- Afficher la liste des résultats à partir de la cellule B3 (par exemple). Les autres résultats seraient en B4, B5, ...
3- Afficher les résultats par ordre alphabétique.
Que dois-je modifier dans le code ci-dessous pour respecter les points 1, 2 et 3 ?
Un grand Merci pour votre aide.
Cdlt.
Jérôme.
Voici le code proposé par Silkyroad :
Sub listeDossiersEtSousDossiers()
Dim Racine As String
Application.ScreenUpdating = False
Racine = "P:\ENERGIE\2018\IDs"
Cible = nbSeparateur(Racine)
ListeReps Racine, True
Application.ScreenUpdating = True
i = 0
End Sub
Sub ListeReps(strDossier As String, strSousDossier As Boolean)
' adapté de Ole P Erlandsen
Dim Fso As Object, SourceFolder As Object
Dim SubFolder As Object
On Error GoTo Fin
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(strDossier)
If strSousDossier Then
For Each SubFolder In SourceFolder.subfolders
i = i + 1
'pour recuperer le chemin complet
'Cells(i, nbSeparateur(SubFolder.Path) - Cible) = SubFolder.Path
'
'pour recuperer uniquement le nom du dossier
Cells(i, nbSeparateur(SubFolder.Path) - Cible) = SubFolder.Name
ListeReps SubFolder.Path, strSousDossier
Next SubFolder
End If
Fin:
End Sub
Function nbSeparateur(Chemin As String) As Byte
Dim m As Integer
Dim Nb As Byte
For m = 1 To Len(Chemin)
If Mid(Chemin, m, 1) = "\" Then
Nb = Nb + 1
m = m + 1
End If
Next m
nbSeparateur = Nb
End Function
Bonjour,
J'ai trouvé pour les points 1 et 2 :
Sub listeDossiersEtSousDossiers()
Dim Racine As String
Application.ScreenUpdating = False
Racine = "P:\ENERGIE\2018\IDs"
Cible = nbSeparateur(Racine)
ListeReps Racine, True
Application.ScreenUpdating = True
i = 0
End Sub
Sub ListeReps(strDossier As String, strSousDossier As Boolean)
' adapté de Ole P Erlandsen
Dim Fso As Object, SourceFolder As Object
Dim SubFolder As Object
On Error GoTo Fin
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(strDossier)
If strSousDossier Then
For Each SubFolder In SourceFolder.subfolders
i = i + 1
'pour recuperer le chemin complet
'Cells(i, nbSeparateur(SubFolder.Path) - Cible) = SubFolder.Path
'
'pour recuperer uniquement le nom du dossier
Cells(2, i+1) = SubFolder.Name 'MODIFIER CETTE LIGNE (point n°2)
\ListeReps SubFolder.Path, strSousDossier\ 'SUPPRIMER CETTE LIGNE (point n°1)
Next SubFolder
End If
Fin:
End Sub
Function nbSeparateur(Chemin As String) As Byte
Dim m As Integer
Dim Nb As Byte
For m = 1 To Len(Chemin)
If Mid(Chemin, m, 1) = "\" Then
Nb = Nb + 1
m = m + 1
End If
Next m
nbSeparateur = Nb
End FunctionEnsuite pour ton point numéro 3 dossier n'est pas trié par ordre alphabétique ?
Bonjour JMassol, bonjour le forum,
Peut-être comme ça :
Public Sub Macro1()
Dim SF As Object
Dim DS As Object
Dim SD As Object
Dim LI As Integer
Set SF = CreateObject("Scripting.FileSystemObject")
Set DS = SF.GetFolder("P:\ENERGIE\2018\IDs")
LI = 3
For Each SD In DS.SubFolders
Cells(LI, "B").Value = SD.Name: LI = LI + 1
Next SD
End SubBonjour,
J'ai effectué les modifs du code tels qu'indiqués et lorsque je lance la macro rien ne se passe ??
Voici le code après modif :
Sub listeDossiersEtSousDossiers()
Dim Racine As String
Application.ScreenUpdating = False
Racine = "P:\ENERGIE\2018\IDs"
Cible = nbSeparateur(Racine)
ListeReps Racine, True
Application.ScreenUpdating = True
i = 0
End Sub
Sub ListeReps(strDossier As String, strSousDossier As Boolean)
' adapté de Ole P Erlandsen
Dim Fso As Object, SourceFolder As Object
Dim SubFolder As Object
On Error GoTo Fin
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(strDossier)
If strSousDossier Then
For Each SubFolder In SourceFolder.subfolders
i = i + 1
'pour recuperer le chemin complet
'Cells(i, nbSeparateur(SubFolder.Path) - Cible) = SubFolder.Path
'
'pour recuperer uniquement le nom du dossier
Cells(2, i + 1) = SubFolder.Name
Next SubFolder
End If
Fin:
End Sub
Function nbSeparateur(Chemin As String) As Byte
Dim m As Integer
Dim Nb As Byte
For m = 1 To Len(Chemin)
If Mid(Chemin, m, 1) = "\" Then
Nb = Nb + 1
m = m + 1
End If
Next m
nbSeparateur = Nb
End Function
la ligne : Racine = "P:\ENERGIE\2018\IDs"
Il faut que tu mettes le chemin don ton dossier entre les ""
Bonjour,
Etant débutant en VBA, pourriez-vous m'expliquer comment fonctionne votre macro ? J'avoue ne pas comprendre son fonctionnement.
Par exemple :
Set SF = CreateObject("Scripting.FileSystemObject") ??
Sinon la macro fonctionne très bien....
Une petite requête supplémentaire. Comment faire pour que les résultats soient affichés par ordre alphabétique ?
Encore merci...
Cdlt.
Jérôme.
Bonjour,
Je ne comprends pas. C'est le cas ..??
Cdlt.
Jérôme
Bonjour,
Dans le code il est écrit :
Racine = "P:\ENERGIE\2018\IDs"
Le dossier est bien entre "" et pourtant cela ne fonctionne pas.
Cdlt.
Jérôme
Tu essais d'obtenir les noms dossiers qui sont sur d'un lecteur amovible ?
Bonjour,
J'ai effectué la modif suivante et cela semble fonctionner.
Public Sub Recuperation_Noms_sous_dossiers()
Dim SF As Object
Dim DS As Object
Dim SD As Object
Dim LI As Integer
Range("B3:B1000").Select
Selection.ClearContents
Set SF = CreateObject("Scripting.FileSystemObject")
Set DS = SF.GetFolder("P:\ENGINEERING\ESW-T\CONTROLES-NON-DESTRUCTIFS-NTM\2-Planning\2.1- Testia\2018\IDs")
LI = 3
For Each SD In DS.SubFolders
Cells(LI, "B").Value = SD.Name: LI = LI + 1
Next SD
Range("B3:B" & LI).Sort Key1:=Range("B3"), Order1:=xlAscending
End Sub
Il s agit d un lecteur sur un réseau.
Cdlt.
Jérôme