Microsoft 365 LISTBOX REPERTOIRE ET SOUS REPERTOIRE

Regueiro

XLDnaute Impliqué
Bonsoir le Forum
Petit problème pour alimenter la 2ème listbox en fonction du choix de la 1ère
Il bute sur chemin ( nothing )
Merci pour votre retour
VB:
Option Explicit
'VBA FileSystemObject (FSO)
'Outils - Références - Microsoft Scripting Runtime à activer
Dim FSO As FileSystemObject
Dim MYFILE As File
Dim DOSSIER As Folder
Dim SOUSDOS As Folder
Dim Chemin As Folder
Dim n As Integer
Dim racine As String
Private Sub b_debut_Click()
Set FSO = New Scripting.FileSystemObject

racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
Set DOSSIER = FSO.GetFolder(racine)
Me.ListBox1.Clear

n = 0

Me.ListBox1.Clear
  For Each SOUSDOS In DOSSIER.SubFolders
       Me.ListBox1.AddItem SOUSDOS.Name                              'DOSSIER.Name
       Me.ListBox1.List(n, 1) = SOUSDOS.Path                                             'DOSSIER.Path
       n = n + 1
   Next
   Me.TextBox1 = DOSSIER.Path
   Me.TextBox2 = n & " Dossiers"
End Sub
Private Sub ListBox1_Click()
Dim rép

Dim F1 As Object
rép = Me.ListBox1.Column(1) & "\" & Me.ListBox1
  Set FSO = New Scripting.FileSystemObject
Set Chemin = FSO.GetFolder(rép)
  Me.ListBox2.Clear
  n = 0
  On Error Resume Next
  'For Each f1 In FSO.GetFolder(MonRepertoire).SubFolders
  For Each SOUSDOS In Chemin.SubFolders
    Me.ListBox2.AddItem Chemin.Name
    Me.ListBox2.List(n, 1) = Chemin.Path
    n = n + 1
  Next
  Me.TextBox1 = Chemin.Path
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
Private Sub UserForm_Initialize()
  racine = "c:\"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set DOSSIER = FSO.GetFolder(racine)
  Me.ListBox1.Clear
  Me.ListBox2.Clear

  n = 0
  For Each SOUSDOS In DOSSIER.SubFolders
       Me.ListBox1.AddItem DOSSIER.Name
       Me.ListBox1.List(n, 1) = DOSSIER.Path
       n = n + 1
   Next
   Me.TextBox1 = DOSSIER.Path
  ' listefichiers DOSSIER.Path
End Sub
 

Pièces jointes

  • XLD REPERTOIRE.xlsm
    23.5 KB · Affichages: 6

patricktoulon

XLDnaute Barbatruc
bonjour
gérer dossier et sub dossier avec seulement 2 listbox me parait un peu leger
dans le sens ou un sub dossier en liste 2 peut lui aussi avoir un/des sub dossier a afficher dans un e eventuelles liste3
et on en fini plus
alors qu'avec une seule liste box et je dis bien une seul il t'est possible de descendre ou remonter l'arborescence d'un dossier exactement de la même manière que le fait l'explorateur windows
plus de soucis de limite de descente dans l'arborescence
 

patricktoulon

XLDnaute Barbatruc
bonjour ChTi160
oui donc un seule étage
dans ce cas la cela peut être fait en moins de 10 lignes avec dir et avec une fonction commune en plus

tiens un exemple en 4eme vitesse à main levée
1 userform
1 textbox "choix dossier"
1 commandbutton
2 listboxs "liste1" et "liste2"

et voila
tu click sur le bouton tu choisi ton dossier
et ca te le liste dans liste1
tu click sur un dossier dans liste1 ça te liste les sous dossiers (du dossier cliqué en liste 1) dans liste2

VB:
Option Explicit
Private Sub CommandButton1_Click()
    Choixdossier = ""
    liste1.Clear: liste2.Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then Choixdossier = .SelectedItems(1): Dir_Commun Choixdossier, liste1
    End With
End Sub

Function Dir_Commun(doss, liste As MSForms.ListBox)
  Dim dossiers$
   liste.Clear
  dossiers = Dir(doss & "\", vbDirectory)
     Do While dossiers <> ""
        If (GetAttr(doss & "\" & dossiers) And vbDirectory) = vbDirectory And Not Left(dossiers, 2) Like "*.*" Then liste.AddItem dossiers
        dossiers = Dir
    Loop
End Function

Private Sub liste1_Click()
Dir_Commun Choixdossier & "\" & liste1.Value, liste2
End Sub
pas besoins de sortir l'artillerie de scriptingfilesystem
;)
demo7.gif
 

Regueiro

XLDnaute Impliqué
Bonjour à Tous.
Merci pour vos réponses, je vais examiner cela ce soir
Il était un peu tard hier soir et la fatigue venant.
Par contre j'ai trouvé mon erreur de hier soir en rouge en rajoutant un msgbox
Rép : avait 2 x le dernier dossier en variable
Enrichi (BBcode):
Private Sub ListBox1_Click()
Dim rép
Dim SOUSDOS As Folder
rép = Me.ListBox1.Column(1) '& "\" & Me.ListBox1
MsgBox rép

  Set FSO = New Scripting.FileSystemObject
  Set DOSSIER = FSO.GetFolder(rép)
'Set Chemin = FSO.GetFolder(rép)
  Me.ListBox2.Clear
  n = 0
  'On Error Resume Next
  'For Each f1 In FSO.GetFolder(MonRepertoire).SubFolders
  For Each SOUSDOS In DOSSIER.SubFolders    'FSO.GetFolder(rép).SubFolders
  'Chemin.SubFolders
    Me.ListBox2.AddItem SOUSDOS.Name
    Me.ListBox2.List(n, 1) = SOUSDOS.Path
    n = n + 1
  Next
  Me.TextBox1 = DOSSIER.Path
  Me.TextBox2 = n & " Dossiers"
 

Regueiro

XLDnaute Impliqué
Merci ChTi160,
Je suis au Boulot, je n'avais pas ouvert ton fichier, Bien vu.
Pour information, le résultat final de ce fichier devrait être :
C:\xxx\xxx\Chantiers
Répertoire principal dans la Listbox1
2016 Chantiers
2017 Chantiers
2018 Chantiers
etc
Sous-Répertoire dans la Listbox2
2016.001 Bulle
2016.099 Charmey
2016.199 Vuadens
Etc
Après lorsque je clic sur la listBox2.
Récupérer la valeur de l'index, admettons
En A1 = 2016.001
En A2 = Bulle
L'idéal, que je puisse sélectionner une cellule avec inputbox
et transférer la valeur dans la cellule choisie
InputBox = C28 = 2016.001 et C29 = Bulle
Merci pour votre retour
 

Regueiro

XLDnaute Impliqué
Re
Admettons C28, la suivante dépend du nombre de ligne que je vais mettre,
entre ce chantier et le suivant voir cei-dessous un exemple aléatoire :
ChantierDésignationCONTRAT
HT
AVENANTS
HT
TOTAL
HT
Report du tableau de facturation 2019
2018.068XLD FRANCE100.00100.00200.00
Prix Revient 2018 - 18.05.2018 au 19.12.2018
Prix Revient 2019 - 14.01.2019 au 24.06.2019
blaaaa
Total Prix Revient
2018.112XXX Suisse100'000.003500.00103'5000
Prix Revient 2018 - 10.10.2018 au 17.12.2018
Prix Revient 2019 - 07.01.2019 au 18.10.2019
Total Prix Revient
2019.012CHTI CHANTIER VILLA FRANCE30'000.0030'000.00
Prix Revient 2018 - Néant
Prix Revient 2019 - 04.02.2019 au 22.11.2019
Total Prix Revient
 
Haut Bas