XL 2013 prb récupération nom listing sous repertoire

[PEX]

bonjour a tous,

cela fais un petite moment que je ne suis pas venu sur le forum. Ayant changer de poste récemment je recommence sur les macros VBA.

je vous explique:
j'ai un répertoire avec des sous répertoires ainsi que des fichiers contenu dans les sous dossier
type : Dossier1 / Dossier1.1 / dossier1.1.1 / fichier.pptx

je souhaiterais créer un listing des fichiers présent ( 1 a 5 dans chaque sous dossier )La macro que j'ai fonctionne pour récuperer l'arboresence des dossiers et ecrire leur noms en fonction du niveau de sous dossier que je souhaite. mon probleme survient apres car il ne me liste que 1 fichier et c'est tout .
je pense avoir fait une erreur dans le code car je pense qu'il faut que je boucle a cette operation mais n'étant pas familiarisé avec les dossier et fichiers sous VBA je rame énormément.

Dim ligne

Sub arborescenceRepertoire()
  racine = "D:\Users\Pex\Desktop\Niv 1" ' 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
  NivMax = 3  ' en fonction du nombre de sous dossier
    Lit_dossier dossier_racine, 1, NivMax
End Sub

Sub Lit_dossier(ByRef Dossier, ByVal niveau, ByVal NivMax)
   Cells(ligne, 1) = String(3 * (niveau - 1), " ") & Dossier.Name
   Cells(ligne, 2) = NombreFichiers(Dossier.Path & "\")
   Cells(ligne, 3) = NomFichiers(Dossier.Path & "\")
   ligne = ligne + 1
   For Each d In Dossier.SubFolders
     If niveau <= NivMax Then Lit_dossier d, niveau + 1, NivMax
   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
Function NombreFichiers(repertoire)
  Set fs = CreateObject("Scripting.FileSystemObject")
  NombreFichiers = fs.GetFolder(repertoire).Files.Count
End Function
Function NomFichiers(repertoire)
  Set fs = CreateObject("Scripting.FileSystemObject")
  NomFichiers = Dir(repertoire)
End Function

je vous joints la macro que je monte et vous verrez par vous meme . je vais monter un Zip avec le style de dossier que je vous parle .

en esperant que vous pourriez m'aidez,

cordialement

pex

 

[Staple1600]

Bonsoir le fil, le forum

Une solution possible (avec les derniers OS de Microsoft)
Avant de lancer la macro test_I, modifier le path du dossier à lister et le nom du fichier CSV
NB: Ne fonctionne pas sur un Mac.

Private Sub Lister(strPath$, Fichier$)
Dim X$
X = strPath & "\" & Fichier
Call Shell("powershell.exe Get-ChildItem -Recurse" & " " & strPath & " " & "| Where { ! $_.PSIsContainer } | Select Name,FullName | export-csv" & " " & X)
End Sub

Sub test_I()
Lister "C:\Users\STAPLE", "listingFIC.csv"
End Sub
Sub Ouvrir_CSV()
Dim F$
F = "C:\Users\STAPLE\listingFIC.csv"
Workbooks.OpenText F, DataType:=1, Comma:=-1
End Sub