Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

jibdu64

XLDnaute Nouveau
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 ?
 
Dernière édition:

Caillou

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

Bonjour,

Avec la bibliothèque Microsoft Scripting Runtime
Code:
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
 

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
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

Code:
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

Code:
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
 
Dernière édition:

jibdu64

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

J'ai sorti des liens de CAILLOU le code suivant

Code:
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

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

Re,

ça ne ressemble pas à mon code !
j'aurais plutôt mis :
Code:
 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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…