Récupérer les noms des sous-dossiers à l'intérieur d'un dossier.

[dfuentes]

Bonjour à tous.

J'aimerais pouvoir lister les noms des sous-dossiers présent dans un dossier. J'ai récupérer ce fichier dans une autre discussion mais je n'arrive pas à l'adapter pour n'avoir que le nom des sous-dossiers.

Merci d'avance.

 

[sousou]

Re : Récupérer les noms des sous-dossiers à l'intérieur d'un dossier.

Bonjour
Par certain, mais ca à l'air de fonctionner comme ceci.
Set objFolder = objShell.BrowseForFolder(&H0&, vMessage, &H1000&, pRacine)

 

[dfuentes]

Re : Récupérer les noms des sous-dossiers à l'intérieur d'un dossier.

Cette fonction me permettra de lister les noms des sous-dossiers ? Je la place où ? Désolé je débute complètement là...

 

[CHALET53]

Re : Récupérer les noms des sous-dossiers à l'intérieur d'un dossier.

bonjour,
pourquoi un autre post

https://www.excel-downloads.com/threads/recuperer-les-noms-de-dossier.86481/

 

[MJ13]

Re : Récupérer les noms des sous-dossiers à l'intérieur d'un dossier.

Bonjour à tous

Tu peux tester ce code:

Public idx As Double, Lecteur
Sub Liste_Dossiers_Seuls()
    t1 = Timer
    On Error Resume Next
    
    idx = 2
    Application.ScreenUpdating = False
    Sheets.Add
        'Lecteur = InputBox("lecteur à scanner?")
        'TousLesDossiersSeuls Lecteur & ":\", 0
        Lecteur = InputBox("Dossier à scanner?")
        TousLesDossiersSeuls Lecteur & "\", 0
        derl = [A65536].End(xlUp).Row
        Range(Cells(1, 1), Cells(derl, 1)).Select
        Application.ScreenUpdating = True
Application.StatusBar = Format(Timer - t1, "0,0" & " secondes pour Lister les dossiers")
End Sub

Sub TousLesDossiersSeuls(LeDossier$, idx As Long)
    Dim FSO As Object, Dossier As Object
    Dim sousRep As Object, Flder As Object
    Dim Fichier As Object, Chemin As String
  On Error Resume Next
   Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
        Set Dossier = FSO.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        idx = idx + 1
        Cells(idx, 1).Value = Flder.Path
Next
   
    'traitement récursif des sous-dossiers
    For Each sousRep In Dossier.subfolders
        TousLesDossiersSeuls sousRep.Path, idx
        'idx = idx + 1
     Next
    Set FSO = Nothing
End Sub