Autres Faire une recherche de sous-dossiers Windows (pas de fichiers) dans un dossier précis à partir de son nom contenu dans une cellule

  • Initiateur de la discussion Initiateur de la discussion Michou9
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Michou9

XLDnaute Occasionnel
Bonjour à tous
J'ai un fichier Excel (environ 500 lignes actuellement)
Dans la colonne A sont contenus des noms de sous dossiers
Je souhaiterais pouvoir faire une recherche de ces sous-dossiers Windows dans un dossier précis à partir de ces noms contenus dans les cellules de cette colonne
Les noms de ces sous-dossiers sont assez long
Je suis sous Excel 2007
Je ne sais pas si c'est réalisable ?
Je viens chercher de l'aide
Merci par avance
 
Solution
Bonsoir @Michou9

Avec votre fichier en Poste #5
VBA sans Module de classe.

VB:
Option Explicit
Option Compare Text

Sub Main()
' Procédure VBA :
' A1 = le chemin complet du dossier générale
' B2 = le chemin complet du (nom du dossier exact en A20) qui noyer dans l arborescence du dossier générale
' B2 = le Nom du dossier exact en A20 s'ouvrent automatiquement
' Recherche :
' A20 = Le Nom du dossier Exact (qui noyer dans l'arborescence du dossier générale)
    Application.ScreenUpdating = False
  
    Dim F1 As Worksheet
    Dim DossierRacine As String
    Dim DossierCherche As String
    Dim CheminTrouve As String
  
    Set F1 = Worksheets(ActiveSheet.Name)
  
    ' Récupération des paramètres
    DossierRacine = F1.Cells(1...
Si ce n'est pas compliqué, je souhaiterais avoir à droite
donc dans la colonne B, directement le nom du nom avec le chemin, sans avoir à cliquer dessus
Dans ce cas autant mettre le chemin d'accès complet en colonne A, le code est plus simple :
VB:
Option Compare Text 'la casse est ignorée
Dim chemin$, fso As Object, a$(), n& 'mémorise les variables

Sub CheminDossierGeneral()
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Sélectionnez le Dossier Général"
    If .Show = False Then End
    [B10] = .SelectedItems(1) 'stockage en B10
End With
End Sub

Sub CheminsDossiers()
If fso Is Nothing Then
    chemin = [B10]
    If Replace(Dir(chemin, vbDirectory), ".", "") = "" Then MsgBox "Le chemin en B10 n'est pas valide !", 48: Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
End If
CheminsDossiersRecursive chemin
With [A12] '1ère cellule de destination
    If n Then .Resize(n) = Application.Transpose(a)
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
Set fso = Nothing
Erase a: n = 0
End Sub

Sub CheminsDossiersRecursive(NomComplet$)
Dim sf As Object
For Each sf In fso.GetFolder(NomComplet).SubFolders
    If InStr(sf.Name, "€") Then
        ReDim Preserve a(n)
        a(n) = sf.Path
        n = n + 1
    End If
    CheminsDossiersRecursive sf.Path
Next sf
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A12].Resize(Rows.Count - 11), Me.UsedRange) Is Nothing Then Exit Sub
Cancel = True
If Replace(Dir(Target, vbDirectory), ".", "") = "" Then MsgBox "Le chemin n'est pas valide !", 48: Exit Sub
Shell "explorer.exe """ & Target & """", vbNormalFocus 'ouvre le dossier
End Sub
 

Pièces jointes

Salut,
j'ai fait un essai de performance avec 300 dossiers qui contiennent € et 200 dossiers sans € et dans tous ces dossiers des sous-dossiers Lien, Photo, Genre, Info
J'arrive à 950 ms avec le code de Job75 du post #91 :
VB:
Sub CheminsDossiers()
Dim bm As New cBenchmark
bm.Start
If fso Is Nothing Then
    chemin = [B10]
    If Replace(Dir(chemin, vbDirectory), ".", "") = "" Then MsgBox "Le chemin en B10 n'est pas valide !", 48: Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
End If
bm.TrackByName "Create fso"
CheminsDossiersRecursive chemin
bm.TrackByName "CheminsDossiersRecursive"
With [A12] '1ère cellule de destination
    If n Then .Resize(n) = Application.Transpose(a)
    .offset(n).Resize(Rows.Count - n - .row + 1).ClearContents 'RAZ en dessous
End With
bm.TrackByName "Affichage"
Set fso = Nothing
Erase a: n = 0
End Sub

et 105 ms avec du code situé dans un Addin.
Code:
Sub CheminsDossiersN()
Dim arr
Dim bm As New cBenchmark
bm.Start
chemin = [B10]
arr = Application.Run("ScanFoldersFiltered", chemin, "€")
bm.TrackByName "ScanFoldersFiltered"
    With Range("A12")
        .Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
    End With
bm.TrackByName "Affichage"
End Sub

En pièce jointe un fichier zip qui contient l'ensemble des répertoires de test. A noter que le zip fait 620 ko alors qu'un 7zip fait 8Ko
Je ne sais pas si l'arborescence correspond à peu près à celle de Michou :
DossierGénéral.png


Nullosse
 

Pièces jointes

Bonjour Job75, nullosse, A tous

Job
Je viens d'intégré la macro dans mon fichier
Tout se passe très bien
Donc un grand merci pour tout votre développement!

Juste un petit problème de lancement de la macro
Celle-ci est directement dans la feuille et non dans un module
Du coup je n'arrive pas à mettre un bouton pour l'activer ?

 
avec du code situé dans un Addin
Que voulez dire par là ?
un Addin c'est un complément, cela permet par exemple d'utiliser d'autres langages que le VBA pour effectuer des actions et en particulier des fonctions que l'on peut appeler à partir du VBA, soit parce que la fonction n'existe pas en VBA ou est difficile à implémenter, soit pour améliorer les performances car le VBA n'est pas le langage le plus performant. Dans le cas présent, cela ne présente pas trop d'intérêts car le VBA semble assez performant pour ce que tu veux faire. En plus un complément c'est un fichier externe qu'il faut installer dans son Excel.
 
un Addin c'est un complément, cela permet par exemple d'utiliser d'autres langages que le VBA pour effectuer des actions et en particulier des fonctions que l'on peut appeler à partir du VBA, soit parce que la fonction n'existe pas en VBA ou est difficile à implémenter, soit pour améliorer les performances car le VBA n'est pas le langage le plus performant. Dans le cas présent, cela ne présente pas trop d'intérêts car le VBA semble assez performant pour ce que tu veux faire. En plus un complément c'est un fichier externe qu'il faut installer dans son Excel.
Merci pour ces explications, me voilà renseigné
 
bonsoir
j'ai téléchargé les dossier en exemple de @nullosse
et j'ai augmenté les option de ma fonction DirPileFolderListDIR

et vous pouvez tester divers type de recherche
VB:
Option Explicit

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'Fonction de listage de dossier dans une récursivité alternative (intra fonction)avec critères utilisant  LA FONCTION DIR DE VBA
'-------------------------------------------------------------
'basée sur le même raisonnement que la DirPileListDIR(patricktoulon)
'------------------------------------------------------------
'Auteur: Patricktoulon
'Version DIR Alternative 1.2
'Méthode que j'ai appelé methode Pile :):)(Lecture de la pile de dossier rempli dynamiquement dans ses propres tours dans la collection)
'Date version : 15/03/2026
'Cette fonction utilise une alternative aux appels récursifs d'une fonction
'En effet dans celle ci la recursivité se fait par le do/loop dans le parcours la collection de folder
'Que je rempli tout au long des tours de boucle sur collection tout en supprimant le premier (le dossier en examen) a chaque tours
'Une alternative interessante a la recursivité classique utilisée en vba(Par rappel successifs de la fonction elle même)
'On a pas besoin de Variables statiques ou variables transportée a chaque tours
'On peu considérer que la encore diviser pour mieux règner reste un dogme qui se verifie
'Puisque chaque tour de do/loop supprime le dossier passé en revue et chaque tours passe en revvue seulement ses sous dossiers
'------------------------------------------------------------------------------------------------

'Un seul inconvénient ici c'est que les dossiers de sont pas classé dans l'ordre
'Il faut faire un tri (voir mes méthodes de tri le quicksort dans les ressources )

'------------------------------------------------------------------------------------------------
'Exemple d'utilisation
'       1° Liste complete de l'arborescence des dossiers
'           x= DirPileFolderListDIR(chemin du dossier maitre)
'
'       2° Liste complete de l'arborescence des dossiers contenant une expression dans leur nom
'           x= DirPileFolderListDIR(chemin du dossier maitre,"blablabla",true,true)
'
'       3° Liste complete de l'arborescence des dossiers ayant le nom ....
'           x= DirPileFolderListDIR(chemin du dossier maitre,nom du dossier,false,true)
'
'       4° Récuperation du chemin complet avec le nom du dossier
'           Folder = DirPileFolderListDIR("chemin dossier maitre", "nom du dossier recherché")
'
'       5° Récuperation du chemin complet avec une partie du nom  du dossier
'           Folder = DirPileFolderListDIR("chemin dossier maitre", "partie nom du dossier recherché")
'
'
'------------------------------------------------------------------------------------------------
'Autrement dit la fonction renvoie un variant/string ou variant()
'------------------------------------------------------------------------------------------------

Sub clear_cell()
    Cells.Clear
End Sub
Sub tri()
    With ActiveWorkbook.Worksheets("Feuil1")
        .Sort.SortFields.Clear
        .Range("A1:A2491").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
    End With
End Sub

Sub testList()
    clear_cell
    'Test de récupération complete de la liste des dossier (et leurs sous dossiers)
    Dim ListeFolder
    ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général")
    If IsArray(ListeFolder) Then
        MsgBox UBound(ListeFolder) & "dossier(s) trouvé(s)"
        Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
        tri
    End If
End Sub

Sub Test_Liste_2()
    clear_cell
    'Test de récupération de la liste des dossiers  ayant "€" dans leur noms
    Dim ListeFolder
    ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "€", True, True)
    If IsArray(ListeFolder) Then
        MsgBox UBound(ListeFolder) & "dossiers trouvés"
        Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
        tri
    End If
End Sub

Sub Test_Liste_3()
    clear_cell
    'Test de récupération de la liste des dossiers  ayant "184€" dans leur noms
    Dim ListeFolder
    ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "148€", True, True)
    If IsArray(ListeFolder) Then
        MsgBox UBound(ListeFolder) & "dossiers trouvés"
        Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
        tri
    End If
End Sub

Sub Test_Liste_4()
    clear_cell
    'Test de récupération de la liste des dossiers  ayant pour nom "Lien"
    Dim ListeFolder
    ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "Lien", , True)
    If IsArray(ListeFolder) Then
        MsgBox UBound(ListeFolder) & "dossiers trouvés"
        Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
        tri
    End If
End Sub

Sub cherche_un_dossier1()
    'Test de récupération d'un dossier en particulier par son nom
    Dim Folder
    Folder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "Machin 148€ 150m @2020 DpJ 154€t")
    If Folder <> "" Then MsgBox Folder
End Sub

Sub cherche_un_dossier2()
    'Test de récupération d'un dossier en particulier avec une partie du nom
    Dim Folder
    Folder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "@2020 DpJ 154€t", True)
    If Folder <> "" Then MsgBox Folder
End Sub


Function DirPileFolderListDIR(dossier As String, Optional ShearchFolder As String = vbNullString, Optional part As Boolean = False, Optional Listing As Boolean = False) As Variant
    Dim ItemVU As String, Foldercollection As Collection, CurrentFolder As String, TbL(), a As Long
    ReDim TbL(1 To 1)
    Set Foldercollection = New Collection
    If ShearchFolder = vbNullString Then ShearchFolder = "*": part = True: Listing = True 'forcera le like a passer si searchfolder est videet listera tout
    If Right(dossier, 1) <> "\" Then dossier = dossier & "\"
    Foldercollection.Add dossier
    Do While Foldercollection.Count > 0
        CurrentFolder = Foldercollection(1)
        Foldercollection.Remove 1
        On Error Resume Next
        ItemVU = Dir(CurrentFolder, vbDirectory)
        If Err.Number <> 0 Then Err.Clear: GoTo NextFolder
        Do Until ItemVU = vbNullString
            If Left(ItemVU, 1) <> "." Then
                If (GetAttr(CurrentFolder & ItemVU) And vbDirectory) = vbDirectory Then
                    'si une des deux condition  passe
                    If part = False And ItemVU = ShearchFolder Or part = True And " " & ItemVU & " " Like "*" & ShearchFolder & "*" Then
                        'si listing=false on prend le premier est on sort
                        If Listing = False Then DirPileFolderListDIR = CurrentFolder & ItemVU & "\": Exit Function
                        'on continue si on est pas sorti
                        a = a + 1: ReDim Preserve TbL(1 To a): TbL(a) = CurrentFolder & ItemVU & "\"
                    End If
                    'on continue a empiler les dosier dans la collection pour qu'il soient examiné
                    Foldercollection.Add CurrentFolder & ItemVU & "\"
                End If
            End If
            ItemVU = Dir()
        Loop
NextFolder:
    Loop
    On Error GoTo 0
    If Listing = True Then
        If a > 0 Then DirPileFolderListDIR = TbL
    End If
End Function

Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.
 

Pièces jointes

Bonsoir le forum,

Comme cela a été dit la méthode avec fso est nettement moins rapide que la méthode avec Dir, voici donc le code avec Dir :
VB:
Dim a$(), n& 'mémorise les variables

Sub CheminDossierGeneral()
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Sélectionnez le Dossier Général"
    If .Show = False Then End
    [B10] = .SelectedItems(1) 'stockage en B10
End With
End Sub

Sub CheminsDossiers()
Dim chemin$
chemin = [B10]
If Replace(Dir(chemin, vbDirectory), ".", "") = "" Then MsgBox "Le chemin en B10 n'est pas valide !", 48: Exit Sub
CheminsDossiersRecursive chemin
With [A12] '1ère cellule de destination
    If n Then .Resize(n) = Application.Transpose(a)
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
Erase a: n = 0
End Sub

Sub CheminsDossiersRecursive(NomComplet)
Dim dossier$, mem$(), nn&, e
NomComplet = NomComplet & "\"
dossier = Dir(NomComplet, vbDirectory)
Erase mem: nn = 0
While dossier <> ""
    If InStr(dossier, "€") Then
        ReDim Preserve a(n)
        a(n) = NomComplet & dossier
        n = n + 1
    ElseIf dossier <> "." And dossier <> ".." Then
        ReDim Preserve mem(nn)
        mem(nn) = NomComplet & dossier
        nn = nn + 1
    End If
    dossier = Dir
Wend
If nn = 0 Then Exit Sub
For Each e In mem
    CheminsDossiersRecursive e
Next e
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A12].Resize(Rows.Count - 11), Me.UsedRange) Is Nothing Then Exit Sub
Cancel = True
If Replace(Dir(Target, vbDirectory), ".", "") = "" Then MsgBox "Le chemin n'est pas valide !", 48: Exit Sub
Shell "explorer.exe """ & Target & """", vbNormalFocus 'ouvre le dossier
End Sub
J'ai mesuré les durées d'exécution de la macro CheminsDossiers sur les mêmess dossiers :

-méthode fso => 11 millisecondes

- méthode Dir => 1,1 milliseconde, donc 10 fois plus rapide.

Dans le dossier zippé joint j'ai mis les fichiers .xlsm des 2 méthodes, testez-les.

Bonne nuit.
 

Pièces jointes

Bonjour le forum,

Avec le code précédent la macro CheminsDossiersRecursive beugue s'il y a des fichiers dans les dossiers.

On l'évitera simplement avec On Error Resume Next (pas besoin d'utiliser GetAttr...) :
VB:
On Error Resume Next
For Each e In mem
    CheminsDossiersRecursive e
Next e
A+
 

Pièces jointes

Dernière édition:
Bonjour le forum,

Avec le code précédent la macro CheminsDossiers beugue s'il y a des fichiers dans les dossiers.

On l'évitera simplement avec On Error Resume Next (pas besoin d'utiliser GetAttr...) :
VB:
On Error Resume Next
For Each e In mem
    CheminsDossiersRecursive e
Next e
A+
Bonjour à tous

Job75

Avec la méthode Fso en tout cas il n'y a pas de problème si il y a des fichiers
J'ai des fichiers directement dans les dossiers, et bien sûr dans les sous-dossiers

Au sujet de mon post 95 que vous n'avez peut-être pas vu
Comme je ne peux pas mettre de bouton Active X (Je ne comprends d'ailleurs pas pourquoi ?)
J'ai mis un Contrôle de formulaire
Moins bien, mais çà fait l'affaire
 
Avec la méthode Fso en tout cas il n'y a pas de problème si il y a des fichiers
J'ai des fichiers directement dans les dossiers, et bien sûr dans les sous-dossiers
Avec la méthode Dir pas de problème non plus et c'est plus rapide, merci de tester le fichier .xlsm du post #101.
Au sujet de mon post 95 que vous n'avez peut-être pas vu
Comme je ne peux pas mettre de bouton Active X (Je ne comprends d'ailleurs pas pourquoi ?)
J'ai mis un Contrôle de formulaire
J'avais bien vu votre post #95 mais pas répondu.

Car il n'y a aucun problème pour mettre des boutons ActiveX ou de formulaire : sur mon fichier il y a 2 boutons !!!
 
Avec la méthode Dir pas de problème non plus et c'est plus rapide, merci de tester le fichier .xlsm du post #101.

J'avais bien vu votre post #95 mais pas répondu.

Car il n'y a aucun problème pour mettre des boutons ActiveX ou de formulaire : sur mon fichier il y a 2 boutons !!!
Des boutons de formulaire Oui
Mais des boutons ActiveX Non

Ce sont 2 boutons de formulaire qu'il y a dans votre exemple
 
Des boutons de formulaire Oui
Mais des boutons ActiveX Non

Ce sont 2 boutons de formulaire qu'il y a dans votre exemple
Bizarre, vous ne savez pas créer des boutons ActiveX et leur affecter un code VBA ? Alors voyez les fichiers joints...
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
869
Retour