VBA: Obtenir le nom des dossiers présents dans un repertoire

[jibdu64]

Bonjour,
je cherche désespérément un code qui a partir d'un chemin ("C:\Users\Documents\agent\2015-2016"), me donne les dossiers présents a l'interieur, sans se soucier des fichiers dans les dossiers.

L'arborescence de mes fichiers et ainsi:

Dossier Parent

2015-2016

Sous Dossier

Gouret
La pierre
....

Je souhaiterais obtenir les noms de tous les dossier du sous dossier.

Auriez vous une idée ?

 

[Caillou]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

Bonjour,

Avec la bibliothèque Microsoft Scripting Runtime

Sub liste_sous_dossier()
  Dim fso As FileSystemObject
  Dim d As Folder
  Dim sd As Folder
  Dim chemin As String
  
  chemin = "c:\wamp"
  
  Set fso = New FileSystemObject
  Set d = fso.GetFolder(chemin)
  
  For Each sd In d.SubFolders
    Debug.Print sd.Name
  Next
End Sub

Caillou

 

[jibdu64]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

merci pour ta proposition Caillou,
mais j'obtiens une erreur a l'exécution dès la ligne 2, "Type défini par l'utilisateur non défini".

 

[BOISGONTIER]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

Bonjour,

Cf Liste des dossiers et sous-dossiers

http://boisgontierjacques.free.fr/fichiers/Fichier/CreeOrgaArborescenceDossier.xls
http://boisgontierjacques.free.fr/fichiers/Fichier/ArborescenceRepertoireSousRep3B.xls
http://boisgontierjacques.free.fr/fichiers/Fichier/TreeViewArborescence.xls

Dim ligne
Sub arborescenceRepertoire()
  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A:E").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
  ligne = 3
  Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = String(3 * (niveau - 1), " ") & dossier.Name
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
End Sub

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Pour un seul niveau

Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = String(3 * (niveau - 1), " ") & dossier.Name
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     If niveau < 2 Then Lit_dossier d, niveau + 1
   Next
End Sub

JB

 

[Caillou]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

il faut référencer la bibliothèque
- Dans VBA
- Outils / Références
- tu coches Microsoft Scripting Runtime

Caillou

 

[jibdu64]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

J'ai sorti des liens de CAILLOU le code suivant

Dim ligne
Sub arborescenceRepertoire()
  racine = "C:\Users\subias.CGPA\Documents\agent"    ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A:E").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
  ligne = 3
  Lit_dossier dossier_racine, 1
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = String(3 * (niveau - 1), " ") & dossier.Name
   'ligne = ligne + 1
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
End Sub

Ce code me sort toute l'arboresence, hors je ne veux que le nom des dossiers de la racine, et pas également le nom de leur contenu ...

 

[Caillou]

Re : VBA: Obtenir le nom des dossiers présents dans un repertoire

Re,

ça ne ressemble pas à mon code !
j'aurais plutôt mis :

 Sub arborescenceRepertoire()
   racine = "C:\wamp"    ' ou un répertoire C:\xxx e.g.
   If racine = "" Then Exit Sub
   Range("A:E").ClearContents
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set dossier = fs.GetFolder(racine)
   ligne = 3
    For Each d In dossier.SubFolders
      Cells(ligne, 1) = d.Name
      ligne = ligne + 1
    Next
 End Sub