XL 2016 Sous-répertoire - valeur

[Aldonanou]

Bonjour,

J'aimerai pouvoir récupérer la valeur d'un sous-répertoire afin de ne pas avoir à insérer la valeur en dure dans le développement de mon formulaire.
Par exemple "C:\Public\SAV NEW 2023\AAAAA" en récupérant la valeur AAAA.

Avec le programme ci-après, je récupère bien les informations :
C:\Public\SAV NEW 2023\AAAAA
C:\Public\SAV NEW 2023\BBBBB
C:\Public\SAV NEW 2023\CCCCC
C:\Public\SAV NEW 2023\DDDDD
C:\Public\SAV NEW 2023\EEEEE
C:\Public\SAV NEW 2023\FFFFF
C:\Public\SAV NEW 2023\GGGGG
C:\Public\SAV NEW 2023\HHHHH
C:\Public\SAV NEW 2023\KKKKK
C:\Public\SAV NEW 2023\MMMMM

mais je ne sais pas comment faire pour obtenir la valeur AAAAA ou BBBBB ....

Sub TousLesDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
'examen du dossier courant
For Each Flder In Dossier.subfolders
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
Next
End Sub 'fs

Sub test()
TousLesDossiers "C:\Public\SAV NEW 2023\", 0
End Sub

Pourriez-vous me venir en aide.

Merci

 

[kiki29]

Salut, une recherche sur JBoisgontier ?

 

[Gégé-45550]

Bonjour,
Si j'ai bien compris, ce serait ça ?

Sub TousLesDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Dim x%
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        Idx = Idx + 1
        Worksheets("Feuil1").Cells(Idx, 1).Value = Flder.Path
        x = InStrRev(Flder.Path, "\")
        Worksheets("Feuil1").Cells(Idx, 2).Value = Right(Flder.Path, Len(Flder.Path) - x)
    Next
End Sub

Cordialement,

 

[Aldonanou]

Bonjour Gégé-45550, merci c'est impeccable, le seul hic c'est que chaque répertoire contient 5 chiffres commençant tous par un zéro qui n'est pas repris, j'aurai dû indiquer des chiffres tout de suite dans mon modèle, désolée de ce contretemps. Comment serait-il possible de corriger ce point. Merci d'avance.

 

[Gégé-45550]

Bonjour Gégé-45550, merci c'est impeccable, le seul hic c'est que chaque répertoire contient 5 chiffres commençant tous par un zéro qui n'est pas repris, j'aurai dû indiquer des chiffres tout de suite dans mon modèle, désolée de ce contretemps. Comment serait-il possible de corriger ce point. Merci d'avance.

Bonjour,
Comme ça, vite fait, je vous propose d'essayer :

Worksheets("Feuil1").Cells(Idx, 2).Value = CStr(Right(Flder.Path, Len(Flder.Path) - x))

Je n'ai pas testé mais il me semble que ça devrait coller.
Cordialement,

 

[Gégé-45550]

Bonjour,
Comme ça, vite fait, je vous propose d'essayer :

Worksheets("Feuil1").Cells(Idx, 2).Value = CStr(Right(Flder.Path, Len(Flder.Path) - x))

Je n'ai pas testé mais il me semble que ça devrait coller.
Cordialement,

Évidemment, cette ligne annule et remplace l'antépénultième ligne du code de la procédure 'TousLesDossiers'

 

[Aldonanou]

Bonjour Gégé-45550 , meilleurs Vœux pour cette nouvelle année. Malheureusement, le sous-répertoire commence par un zéro qui ne remonte pas, je n'ai que 2564 au lieu de 02564. Auriez-vous une autre solution ? Merci Cordialement

 

[Gégé-45550]

Bonjour Gégé-45550 , meilleurs Vœux pour cette nouvelle année. Malheureusement, le sous-répertoire commence par un zéro qui ne remonte pas, je n'ai que 2564 au lieu de 02564. Auriez-vous une autre solution ? Merci Cordialement

Bonjour et meilleurs vœux,
testez ça :

Sub TousLesDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object
Dim x%, y$, NomRep As New Collection
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each sousRep In Dossier.subfolders
        Idx = Idx + 1
        Worksheets("Feuil1").Cells(Idx, 1).Value = sousRep.Path
        x = InStrRev(sousRep.Path, "\")
        y = Right(sousRep.Path, Len(sousRep.Path) - x)
        NomRep.Add y
    Next
    For x = 1 To Idx
        Worksheets("Feuil1").Cells(x, 2).NumberFormat = "@"
        Worksheets("Feuil1").Cells(x, 2).Value = NomRep.Item(x)
    Next
    Set NomRep = Nothing
End Sub

Cordialement,

 

[patricktoulon]

bonjour à tout les deux et meilleurs veux pour cette nouvelle année
je ne vois pas l'utilité d'aller chercher les fonction (string) instr rigth etc..
je ne saisie pas non plus l'utilisation d'une collection si il n'y a pas de récursivité
(pour aller chercher des eventuels sub sub dossier)
l'object folder a sa propriété ".name"

Sub test()
    Dossier$ = "C:\Public\SAV NEW 2023"
    TousLesDossiers Dossier
End Sub

Sub TousLesDossiers(LeDossier$)
Dim fso As Object, Flder As Object
Dim tbl(1 To 10000, 1 To 2)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        Idx = Idx + 1
        tbl(Idx, 1) = Flder.Path
        tbl(Idx, 2) = Flder.Name
    Next
    With Worksheets("Feuil1").Cells(1).Resize(Idx, 2)
        .Value = tbl
        .EntireColumn.AutoFit
    End With
End Sub

si il devait y avoir éventuellement une recherche de sous sous dossiers il faudra alors passer en fonction récursive

 

[Gégé-45550]

bonjour à tout les deux et meilleurs veux pour cette nouvelle année
je ne vois pas l'utilité d'aller chercher les fonction (string) instr rigth etc..
je ne saisie pas non plus l'utilisation d'une collection si il n'y a pas de récursivité
(pour aller chercher des eventuels sub sub dossier)
l'object folder a sa propriété ".name"

Sub test()
    Dossier$ = "C:\Public\SAV NEW 2023"
    TousLesDossiers Dossier
End Sub

Sub TousLesDossiers(LeDossier$)
Dim fso As Object, Flder As Object
Dim tbl(1 To 10000, 1 To 2)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        Idx = Idx + 1
        tbl(Idx, 1) = Flder.Path
        tbl(Idx, 2) = Flder.Name
    Next
    With Worksheets("Feuil1").Cells(1).Resize(Idx, 2)
        .Value = tbl
        .EntireColumn.AutoFit
    End With
End Sub

si il devait y avoir éventuellement une recherche de sous sous dossiers il faudra alors passer en fonction récursive
Regarde la pièce jointe 1159466

Bonjour Patrick et merci pour cette "leçon".
J'avais juste repris le code créé par aldonanou pour l'adapter à son besoin, sans tout réécrire.
Comme d'habitude, ton code est excellent.
Juste une réflexion en passant : je ne vois pas la différence entre une collection et une variable tableau, on obtient le même résultat avec une collection sans être obligé de pré-dimensionner (ou de redimensionner) la variable tableau, donc ni problème de place mémoire, ni problème de taille de code.
Pour finir, il convient de modifier légèrement ton code pour formater la colonne 2 en texte, afin de répondre complètement au besoin d'aldonanou, comme ceci :

Sub TousLesDossiers(LeDossier$)
Dim fso As Object, Flder As Object
Dim tbl(1 To 10000, 1 To 2)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        Idx = Idx + 1
        tbl(Idx, 1) = Flder.Path
        tbl(Idx, 2) = Flder.Name
    Next
    With Worksheets("Feuil1").Cells(1).Resize(Idx, 2)
        .NumberFormat="@"            'Formate les cellules en texte pour afficher le zéro initial
        .Value = tbl
        .EntireColumn.AutoFit
    End With
End Sub

Bien amicalement

 

[patricktoulon]

re
Bonjour @Gégé-45550

1. la collection est un object donc plus lourd
2. avec le listing de fichier préférer garder la collection pour stocker les chemin des folder pour sur boucler pour les sub sub folders(eventuellement pour la recursivité )

après si tu y tiens si tu veux
perso je pars du principe que pour percer un trou dans une planche je vais pas utiliser une station de forage
je te fait un exemple vite fait si tu veux

 

[youky(BJ)]

Bonjour,
Si tu as récupéré les chemins complets pourquoi ne pas utiliser SPLIT
exemple
Sub essai()
tablo = Split("C:\Public\SAV NEW 2023\AAAAA", "\")
MsgBox tablo(UBound(tablo))
End Sub
Bruno

 

[patricktoulon]

Bonjour @youky(BJ) meilleurs veux
split est le plus lourd des fonctions string

@Gégé-45550
comme ça vite fait
voici une fonction récursive visitant toute l’arborescence d'un dossier maître(donc avec les sub dossiers )
et comme on liste pas fichiers et dossier mais seulement fichier la collection bye!bye!
on se contente d' incrémenter la variable tableau(tbl) et l'alimenter

Sub testx()
Dim racine$
    racine = "C:\Public\SAV NEW 2023"
    tableau = RécursiveListDossier(racine, True)
    With Cells(1, 1).Resize(UBound(tableau), 2)
        .Value = tableau
        .EntireColumn.AutoFit
    End With
End Sub
'
'
Private Function RécursiveListDossier(dparent, Optional raz As Boolean = False) As Variant
Static IdX As Long: Static tbl(): Dim FSO As Object, Lparent As Object, SubFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    If raz Then IdX = 0: ReDim Preserve tbl(1 To 2, 1 To 1)
    Set Lparent = FSO.GetFolder(dparent)
    IdX = IdX + 1: ReDim Preserve tbl(1 To 2, 1 To IdX)
    tbl(1, IdX) = Lparent.Path: tbl(2, IdX) = Lparent.Name
    'boucles sur les sous dossiers
    For Each SubFolder In Lparent.SubFolders
        RécursiveListDossier SubFolder.Path            ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et L qui est déjà peut être remplie
    Next SubFolder
    RécursiveListDossier = Application.Transpose(tbl)
End Function

 

[Aldonanou]

Bonsoir / Bonjour et merci à tous, je teste cela dans quelques heures au travail. Bonne nuit ou bonne journée !