XL 2019 Ajouter quelques propriétés au code existant (liste répertoires et sous-répertoires)

re4

XLDnaute Occasionnel
Bonjour,
le code que j'ai récupéré ici 'https://www.excel-downloads.com/threads/vba-liste-dossiers-et-sous-dossiers-dun-dosssier.126930/page-2#posts fonctionne très bien et merci à l'auteur mais je voudrai ajouter à la colonne après le dernier niveau le poids du répertoire racine et des sous-répertoires.
J'ai bien tenté une petite modif mais je n'arrive qu'a afficher qu'a la colonne +1 (modif en '***)
Avec votre aide j'arriverai peut-être à afficher d'autres propriétés au besoin...
Bonne journée

VB:
'https://www.excel-downloads.com/threads/vba-liste-dossiers-et-sous-dossiers-dun-dosssier.126930/page-2#posts
Dim ligne
Sub arborescenceRepertoire()
  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A:h").ClearContents
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
 
  ligne = 3
  Lit_dossier dossier_racine, 1

'*** Cells(3, 2) = fs.getfolder(racine).Size
 
  End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, niveau) = dossier.Name

'*** Cells(ligne, niveau + 1) = dossier.Size

   ligne = ligne + 1
     For Each d In dossier.SubFolders
      Lit_dossier d, niveau + 1
   '  MsgBox niveau
    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
 
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Re4,
En PJ un bricolage, j'ai rajouté la taille des répertoires en colonne I avec :
VB:
'-----------------------------------------------
    ' Ligne ajoutée
    Cells(ligne, "I") = fs.GetFolder(dossier).Size
'-----------------------------------------------
et modifié Lit_dossier pour transférer fs à la sub.
 

Pièces jointes

  • Classeur1.xlsm
    18.5 KB · Affichages: 10

re4

XLDnaute Occasionnel
Bonjour,
Merci beaucoup, ça fonctionne, est'il possible que le poids s'affiche juste après la colonne du dernier niveau ?
Il me semble qu'avec cette condition l'on ne sera pas limité par le nombre de sous-répertoires
Exemple :
pour 2 sous-repertoires affichage en colonne D (racine + sous-rep)
pour 3 sous-repertoires affichage en colonne E
 

re4

XLDnaute Occasionnel
Merci sylvanu, j'ai du mal poser ma requête, je ne voudrait pas que cela s'affiche immédiatement
à droite mais que tout s'affiche à la dernière colonne non utilisée, dans l'exemple ci-dessous en colonne E pour 3 sous-répertoires, colonne F s'il y avait 4 sous rep.
test.PNG

Peut-être faut'il déterminer le nombre de niveau dès le départ ?
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Désolé, mais avec cette structure je ne sais pas faire car lors du déroulement on n'a pas connaissance des dossiers qui vont suivre.
Peut être mettre en colonne Z, et à la fin supprimer les colonnes vides ?
Ou encore mettre en colonne A, guère orthodoxe mais plus simple à mettre en place.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Avec un peu de persévérance. Je mémorise la dernière colonne utilisée dans une variable globale et supprime d'un coup toutes les colonne vide avec :
VB:
If niveau + 1 > GdNiveau Then GdNiveau = niveau + 1
Code:
    ' Suppression colonnes vides
    Application.ScreenUpdating = False
    Range(Cells(1, GdNiveau + 1), Cells(65500, 25)).Select
    Selection.Delete Shift:=xlToLeft
    [A1].Select
    Application.ScreenUpdating = True
Déjà plus esthétique.
 

Pièces jointes

  • Classeur1(V4).xlsm
    21.9 KB · Affichages: 11

Discussions similaires

Statistiques des forums

Discussions
311 705
Messages
2 081 721
Membres
101 803
dernier inscrit
astyx26