Résolu Macro pour répertorier les dossiers d'un chemin d'accès

[apapa59]

Bonjour à tous
Je souhaiterais réaliser une macro sous Excel qui fournisse une liste des dossiers présents dans un répertoire donné, pour ensuite faire afficher cette liste dans un menu déroulant pour une cellule.
Après quelques recherches, j'ai trouvé une macro qui retourne la liste voulue

Function ChercherRépertoire(MyPath) As Variant
Dim MaListe() As String
Dim a As Integer
a = 0
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
             
    If MyName <> "." And MyName <> ".." Then
            
        If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            ReDim Preserve MaListe(a)
            MaListe(a) = MyName
            a = a + 1
        End If  '
    End If
    MyName = Dir
    Loop
    If a = 0 Then
          ReDim Preserve MaListe(0)
          MaListe(0) = "-----Aucun Projet-----"
    Else
    End If
   
ChercherRépertoire = MaListe
End Function

Function RépertoireExiste(Chemin As String) As Boolean
On Error Resume Next
RépertoireExiste = GetAttr(Chemin) And vbDirectory
    If RépertoireExiste = True Then
        Exit Function
    Else
        MkDir (Chemin)
    End If
End Function
Private Sub Userform_initialize()
Dim Liste As Variant
Dim Répertoire As String
Répertoire = "A:\Le_repertoir_où_faire_la_recherche\"
Call RépertoireExiste(Répertoire)
Liste = ChercherRépertoire(Répertoire)

End Sub

Mais je ne sais pas ensuite comment exploiter cette liste.
Merci de votre aide


(Par souci d'honnêteté voila l'origine du code

Vous devez être connecté pour voir les liens.

 

[zeb]

Salut,

Mouhais, code archaïque, quand même.
Voici quelque chose de plus moderne, plus simple et plus clair :

Dim FSO As Object, folder As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
    
For Each folder In FSO.GetFolder("C:\DONNEES").SubFolders
   MsgBox folder.Path
Next

Maintenant, aide-toi : branche l'enregistreur de macro et configure à la main ta cellule. Arrête l'enregistrement et étudies-en le code. Le plus dur est de coupler ce code, et le précédent - celui que je te propose ou celui de hardware, au choix. On peut d'aider

 

[apapa59]

Puissant
Aux vues du code enregistré, je dois créer une èspece de liste de charactères par concaténation du style "Dossier1;Dossier2"..." et placer cette chaine dans le champ approprié ("Formula1")
Le tout est de pouvoir extraire simplement les noms de dossier (avec Dir) et de créer cette concatenation. J'avoue ne pas avoir beaucoups d'idées quant à ça...

 

[zeb]

Euh, pas d'accord du tout.

Que te propose l'enregistreur de macro (attention, code moche) ?

Le tout est de pouvoir extraire simplement les noms de dossier et de créer cette concatenation. J'avoue ne pas avoir beaucoups d'idées quant à ça...

Ça me semble pourtant très facile ! Au lieu de mettre un MsgBox comme dans mon exemple, tu réalises la concaténation :spamafote:

 

[apapa59]

Mon problème étant de ne pas savoir exactement quel objet est renvoyé par la ligne :

For Each folder In FSO.GetFolder("C:\DONNEES" ).SubFolders
MsgBox folder.Path

Parce qu'en enlevant le ".path" accolé au "folder", la Msgbox renvoie aussi le chemin. Et je voudrais extraire juste les noms de dossier ("MsgBox avec Dir ne renvoient rien)

 

[apapa59]

Ah et e code renvoyé par l'enregistreur est:

Sub enregistrement()
    Range("K15").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="a;b;c;d;e"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub

C'est à la place de "a;b;c;d;e" que je comptais placer ma chaine...

 

[apapa59]

Attention gros bricolage

Public Const Chemin2 = "D:\DONNEES\"

Sub liste_projet()
Dim FSO As Object, folder As Object
Dim chaine As String
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each folder In FSO.GetFolder(Chemin2).SubFolders
chaine = chaine + ";" & Right(folder, Len(folder) - Len(Chemin2))
Next
chaine = Right(chaine, Len(chaine) - 1)

End Sub

 

[zeb]

Eh, ce gros bricolage est ce que je voulais que tu nous proposes.
Pas question pour moi de faire ton boulot. Mais dès lors que c'est le produit de ton propre effort, je veux bien t'aider à l'améliorer. Et même à en faire quelque chose de très pro

------------------------------------------

Ma bien-nommée variable folder est un objet

Vous devez être connecté pour voir les liens.

, élément de la collection

Vous devez être connecté pour voir les liens.

.
C'est donc un objet qui propose plusieurs méthodes et attributs. L'attribut par défaut est Path, c'est pourquoi tu obtients la même chose que moi en ne rien précisant. Mais je préfère être explicite.
Et si on utilisait l'attribut Name plutôt ?

Sub liste_projet()
	Const chemin = "D:\DONNEES\"
	Dim FSO As Object, folder As Object
	
	Set FSO = CreateObject("Scripting.FileSystemObject" )

	For Each folder In FSO.GetFolder(chemin).SubFolders
		MsgBox "Le sous-dossier courant est : " & folder.Path & "." & vbCrLf & "Son petit nom est : " & folder.Name & "."
	Next

End Sub

Bon maintenant, associer une validation à une cellule :

Range("K15" ).Select
With Selection.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:="a;b;c;d;e"
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With

Beurk :vomi:

Alors déjà, quand je vois un Select suivi d'un Selection, je condense ! (cherche sur ce site pourquoi... allez...)
Et je retire le With, parce que ça me perturbe quelque peu.
Et puis il ne faut pas mettre des points-virgules, mais des virgules... Merci l'enregistreur de macro
Tu peux essayer de relancer ta macro, tu n'obtiendras pas le résulat escompté.

Ca donne :

Range("K15" ).Validation.Delete
Range("K15" ).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="a,b,c,d,e"
Range("K15" ).Validation.IgnoreBlank = True
Range("K15" ).Validation.InCellDropdown = True
Range("K15" ).Validation.InputTitle = ""
Range("K15" ).Validation.ErrorTitle = ""
Range("K15" ).Validation.InputMessage = ""
Range("K15" ).Validation.ErrorMessage = ""
Range("K15" ).Validation.ShowInput = True
Range("K15" ).Validation.ShowError = True

Ligne 1, on supprime la validation précédente avant d'en ajouter une nouvelle. C'est prudent.
Ligne 2, on ajoute donc notre liste.
Pour le reste, il semble que ce soient des valeurs par défaut. Bon.

Je vire tout ce qui n'est pas inutile :

Range("K15").Validation.Delete
Range("K15").Validation.Add xlValidateList, , xlBetween, Formula1:="a,b,c,d,e"

Ah bah ça fait du ménage.

Juste une petite vérif :

Range("K15").Validation.Delete
Range("K15").Validation.Add xlValidateList, , xlBetween, Formula1:="a,b,c,d,e,"

J'ai laissé une virgule en trop à la fin. Ca n'a pas l'air de le déranger.

On reprend avec la boucle sur les sous-dossiers :

Const chemin = "D:\DONNEES\"

Dim FSO As Object, folder As Object
Dim chaine As String

Range("K15").Validation.Delete
Set FSO = CreateObject("Scripting.FileSystemObject" )

chaine = "" ' // Attention, avec VB. On n'est sûr de rien.
For Each folder In FSO.GetFolder(chemin).SubFolders
	chaine = chaine & folder.Name & ","
Next

Range("K15").Validation.Add xlValidateList, , xlBetween, Formula1:=chaine

Alors, ne t'avais-je pas dis que c'était simple :sol:

 

[zeb]

Bon alors pour aller plus loin, on va non plus se baser sur des objets aléatoires, mais au contraire, se baser sur des objets bien définis.

Dans le menu Outils/Références de l'éditeur VBA, on va ajouter Windows Script Host Object Model. Ça pointe en fait sur la bibliothèque IWshRuntimeLibrary définie dans le fichier %windir%\System32\wshom.ocx.

Maintenant, on peut utiliser de vrais objets :

Option Explicit

...

Const chemin = "D:\DONNEES\"

Dim FSO As New FileSystemObject
Dim fldr As Folder
Dim filelist As String

Range("K15").Validation.Delete

filelist = ""
For Each fldr In FSO.GetFolder(chemin).SubFolders
    filelist = filelist & fldr.Name & ","
Next

Range("K15").Validation.Add xlValidateList, , xlBetween, Formula1:=filelist

Enjoy!

 

[apapa59]

Merci pour le petit cours

Pas question pour moi de faire ton boulot

mais tu m'as quand même vraiment bien aidé, et je t'en remercie sincèrement, ne serait-ce que pour le temps que tu as passé à écrire tout ça !
En revanche je n'ai pas vraiment saisi l’intérêt de la dernière manip...

 

[apapa59]

Meilleure réponse sélectionnée par apapa59.

 

[zeb]

Ce site est un forum d'entraide. :spamafote:

Je te propose une solution, puis des éléments pour aller plus loin.

Tu te demandais "Mon problème étant de ne pas savoir exactement quel objet est renvoyé par la ligne ..."

Si tu définis ton objet explicitement, plus de problème, tu sais exactement de quoi tu parles. En plus, tu peux obtenir de l'aide de VBA directement au cours de la frappe :

1° Référence Windows Script Host Object Model
2° Déclare une variable de type Folder :

Dim fldr As Folder

3° Tape sur une nouvelle ligne le nom de ta variable suivi d'un point :

fldr.

Et là, une petite fenêtre s'ouvre pour te proposer toutes les méthodes et tous les attributs possibles pour ton objet. L'écriture du code en est grandement simplifier, tu ne trouves pas ?