XL 2019 Contenu de répertoire affiché dans feuille

[MarcDJ]

Bonjour,

J'aimerais, d'une façon simple, ouvrir un répertoire et afficher son contenu dans la colonne d'une feuille.

Avec un méthode FileSystemOject j'arrive à ouvrir mon répertoire, à afficher le contenu dans ma fenêtre d'exécution,
Mais je voudrais que cela s'affiche dans une colonne de ma feuille Excel.

Sub Obtenir_Nom_SousRepertoire()

'Afficher le nom des sous-repertoires de repertoire

Dim MyFSO As FileSystemObject
Dim MyFolder As Folder
Dim MyFile As File
Dim MySubfolder As Folder

Set MyFSO = New FileSystemObject
Set MyFolder = MyFSO.GetFolder("D:\Test")

For Each MySubfolder In MyFolder.SubFolders 'Pour chaque sous-repertoire
    Debug.Print MySubfolder.Name 'Afficher le nom du sous-repertoire "D:\Test"
Next MySubfolder 'Fermer la boucle

End Sub

Merci d'avance pour vos réponses.

 

[Dranreb]

Bonsoir.
Précisions. La macro de @dysorthographie liste en colonne A à partir de la cellule A1 de la feuille active uniquement les sous dossiers d'un dossier racine ayant pour chemin D:\Test
Je ne l'ai pas testée mais n'ai aucune raison de craindre qu'elle ne marcherait pas, si toutefois ce dossier racine existe, et s'il possède des sous dossiers, qui seuls vous intéressent, à l'exclusion des éventuels fichiers qu'il contiendrait aussi, des sous-sous dossiers éventuels, avec aussi leurs propres fichiers, etc.
Peut être devriez vous joindre un classeur montrant ce que vous voudriez exactement …

 

[Dranreb]

Bonjour.
Au cas où, je propose quelque ajouts à sa procédure :

Sub ObtenirNomSousRepertoire()
'Afficher le nom des sous-repertoires de repertoire
   Const CheminDossier = "D:\Test" ' Testé sur : = "C:\Users\Luck\Documents\XLD" '
   Dim MyFSO As FileSystemObject
   Dim MyFolder As Folder
   Dim MyFile As File
   Dim MySubfolder As Folder
   Set MyFSO = New FileSystemObject
   If Not MyFSO.FolderExists(CheminDossier) Then
      MsgBox CheminDossier & vbLf & "Ce dossier n'existe pas.", _
      vbCritical, "ObtenirNomSousRepertoire"
      Exit Sub: End If
   Set MyFolder = MyFSO.GetFolder(CheminDossier)
   Dim Ligne As Integer
   Columns("A").ClearContents
   For Each MySubfolder In MyFolder.SubFolders 'Pour chaque sous-repertoire
      Ligne = Ligne + 1
      Cells(Ligne, "A").Value = MySubfolder.Name 'Afficher le nom du sous-repertoire "D:\Test" dans les cellules A1:AXXX
      Next MySubfolder 'Fermer la boucle
   Select Case MyFolder.SubFolders.Count
      Case 0: MsgBox MyFolder.Path & " :" & vbLf & "Ne contient aucun dossier", _
         vbExclamation, "ObtenirNomSousRepertoire"
      Case 1: MsgBox MyFolder.Path & " :" & vbLf & "Un seul dossier trouvé.", _
         vbInformation, "ObtenirNomSousRepertoire"
      Case Else: MsgBox MyFolder.Path & " :" & vbLf & MyFolder.SubFolders.Count & " dossiers listés.", _
         vbInformation, "ObtenirNomSousRepertoire"
      End Select
   End Sub

 

[MarcDJ]

Bonjour dysorthographie,

Je suis vraiment désolé, je n'avais pas remarqué, que vous aviez déjà complété le code pour le listage
dans la feuille. Le code, comme cela est vraiment ressemblant en effet.

Encore un grand merci.

 

[MarcDJ]

Bonjour Dranreb,

Je dois malheureusement partir aujourd'hui, je regarde à votre code et je reviens vers vous.

Merci de m'aider.

 

[Dranreb]

J'ai aussi pondu ça, maintenant :

Sub ContenuChemins()
   Dim FSO As New FileSystemObject, Chemin
   ActiveSheet.Columns("A:H").ClearContents
   ActiveSheet.[A1:H1].Value = Array("Path", "FileName", "Size", "Last modified", "R/O", "Hid.", "Sys", "Chg")
   ActiveSheet.[A1].Select
   With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = True
      .Show
      If .SelectedItems.Count = 0 Then Exit Sub
      For Each Chemin In .SelectedItems
         DossFicSsDoss FSO.GetFolder(Chemin)
         Next Chemin
      End With
   ActiveSheet.[B:H].EntireColumn.AutoFit
   End Sub
Sub DossFicSsDoss(ByVal Fdr As Folder)
   Dim Fls As Files, Fds As Folders, Fle As File, T(1 To 1, 1 To 8)
   If Fdr.Attributes And &H40 Then Exit Sub
   T(1, 1) = Fdr.Path
   T(1, 5) = IIf(Fdr.Attributes And 2, ChrW$(&H2713), "—")
   T(1, 6) = IIf(Fdr.Attributes And 4, ChrW$(&H2713), "—")
   T(1, 7) = IIf(Fdr.Attributes And 8, ChrW$(&H2713), "—")
   T(1, 8) = IIf(Fdr.Attributes And 32, ChrW$(&H2713), "—")
   Selection(2, 1).Select
   Selection.Resize(, 8).Value = T
   On Error Resume Next ' On peut avoir des Err 70: Permission refusée
   Set Fls = Fdr.Files
   If Err = 0 Then
      For Each Fle In Fls
         T(1, 1) = Empty
         T(1, 2) = Fle.Name
         T(1, 3) = Fle.Size
         T(1, 4) = Fle.DateLastModified
         T(1, 5) = IIf(Fle.Attributes And 2, ChrW$(&H2713), "—")
         T(1, 6) = IIf(Fle.Attributes And 4, ChrW$(&H2713), "—")
         T(1, 7) = IIf(Fle.Attributes And 8, ChrW$(&H2713), "—")
         T(1, 8) = IIf(Fle.Attributes And 32, ChrW$(&H2713), "—")
         Selection(2, 1).Select
         Selection.Resize(, 8).Value = T
         Next Fle: End If
   Err.Clear
   Set Fds = Fdr.SubFolders
   If Fds.Count = 0 Then Exit Sub
   If Err Then Exit Sub
   On Error GoTo 0
   For Each Fdr In Fds
      DossFicSsDoss Fdr
      Next Fdr
   End Sub

 

[MarcDJ]

Re dysorthographie,

Votre code est parfait, il fonctionne très bien.

Une ligne rajoutée, une variable à déclarer et le tour est joué avec ma façon de coder.

Où puis-je trouver du code VBA pour la manipulation des fenêtres ?

Cela m'a fortement aidé, je peux enfin continuer.