XL 2016 liste des sous répertoire

[MOEZ-TUN]

Bonjour
je n(est pas réussi de changer ce macro pour obtenu la liste des sous répertoire au lieu de liste des fichiers

Sub BoucleFichiers()
Dim Chemin As String, Fichier As String, i As Integer
' Efface liste
Range("B:B").ClearContents
'Définit le répertoire contenant les fichiers,
Chemin = [D2]
'Boucler sur tous les types de fichiers:
'Fichier = Dir(Chemin & "*.*")
i = 1
Do While Len(Fichier) > 0
' Range le nom du fichier dans la colonne A
Cells(i, 2) = Fichier
i = i + 1 ' incrément N° de ligne
Fichier = Dir()
Loop
End Sub

 

[Dranreb]

Bonjour.
J'ai proposé dernièrement ce code qui liste tout, récursivement :

Option Explicit
Private TRés(), LCou As Long, FSO As New FileSystemObject
Sub ListeFic()
   ReDim TRés(1 To 10000, 1 To 2)
   LCou = 0
   Lister FSO.GetFolder(ActiveSheet.Cells(2, "D").Value)
   ActiveSheet.Rows(3).Resize(10000).Delete
   ActiveSheet.[A3].Resize(LCou, 2).Value = TRés
   Erase TRés
   End Sub
Private Sub Lister(ByVal Fdr As Scripting.Folder)
   Dim ChemDoss As String, FdrS As Scripting.Folder, Fle As Scripting.File
   ChemDoss = Fdr.Path
   On Error Resume Next
   For Each Fle In Fdr.Files
      If Fle Is Nothing Then Exit For
      LCou = LCou + 1
      TRés(LCou, 1) = ChemDoss
      TRés(LCou, 2) = Fle.Name
      Next Fle
   For Each FdrS In Fdr.SubFolders
      If FdrS Is Nothing Then Exit Sub
      Lister FdrS: Next FdrS
   End Sub

Nécessite la référence Microsoft Scripting Runtime

 

[Robert]

Bonjour le fil, bonjour le forum,

une autre proposition :

Sub BoucleFichiers()
Dim EF As Object 'déclare la variable EF (Exporateur de Fichiers)
Dim D As Object 'déclare la variable D (Dossier)
Dim SD As Object 'déclare la variable SD (Sous Dossier)
Dim SDT As Object 'déclare la variable SDT (Sous Dossier Trouvé)
Dim I As Integer 'déclare la variable I (Incrément)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set EF = CreateObject("Scripting.FileSystemObject") 'définit la variable EF
Set D = EF.GetFolder(Range("D2").Value) 'définit la variable D
Set SD = D.Subfolders 'définit la variable SD
For Each SDT In SD 'boucle sur tous les sous dossier trouvé
    I = I + 1 'incrémente I
    Cells(I, 2).Value = SDT.Name 'renvoie le nom du sous dossier trouvé dans la cellule ligne I colonne
Next SDT 'prochain sious dossier trouvé de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Terminé !" 'message
End Sub

 

[Rouge]

Bonjour à tous,

Et de trois, avec 2 méthodes qui donnent des résultats différents.

Sub ExtraireTousLesRepertoires1()
    Dim Chemin As String, Fichier As String, i As Integer
    Dim R As Object
    Set R = CreateObject("scripting.filesystemobject")
    Columns(2).ClearContents
    If Right(Range("D2"), 1) <> "\" Then Chemin = Range("D2") & "\" Else: Chemin = Range("D2")
    ChDir (Chemin)
    myFolder = CurDir(Chemin)
    Set mainFolder = R.GetFolder(myFolder)
    For Each f In mainFolder.SubFolders
        i = i + 1
        Cells(i, 2) = f
    Next f
End Sub


Sub ExtraireTousLesRepertoires2()
    Columns(3).ClearContents
    If Right(Range("D2"), 1) <> "\" Then Chemin = Range("D2") & "\" Else: Chemin = Range("D2")
    SousRep = Dir(Chemin, vbDirectory)
    i = 1
    Do While SousRep <> ""
        If SousRep <> "." And SousRep <> ".." Then
            If (GetAttr(Chemin & SousRep) And vbDirectory) = vbDirectory Then
                Cells(i, "C") = SousRep
                i = i + 1
            End If
        End If
        SousRep = Dir
    Loop
End Sub

Cdlt

 

[MOEZ-TUN]

Merci a tous
Bien fonctionne