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

[Michou9]

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

 

[Michou9]

Merci TooFatBoy, mais je crois que Sylvanu s'est retiré de cette discussion, et moi non plus je ne maitrise pas assez le Vba pour solutionner cette erreur

Merci TooFatBoy, mais je crois que Sylvanu s'est retiré de cette discussion, et moi non plus je ne maitrise pas assez le Vba pour solutionner cette erreur

 

[Michou9]

Merci TooFatBoy, mais je crois que Sylvanu s'est retiré de cette discussion, et moi non plus je ne maitrise pas assez le Vba pour solutionner cette erreur

Bonsoir Laurent
Ce n'est pas la recherche qui ne fonctionne pas, c'est l'ouverture du dossier recherché

 

[Michou9]

Le code qui ne fonctionne pas c'est "wsSh.Run Chemin"
Ou du moins il fonctionne si le dossier comporte qu'un seul mot
Mais pas si il y a plusieurs mots
cartographie c'est bon
cartographie Française, cela plante
Le message d'erreur est peu dans la discussion

 

[Michou9]

Bonsoir @Michou9

Bien moi j ai reussit.
A1 = le dossier source
A20 = le dossier noyer dans l arborescence
B2 = le chemin complet de A20
Ouvrir le dossier comment (A20)

C'est très bien, puis-je avoir ton fichier, merci d'avance

 

[laurent950]

Bonsoir @Michou9

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

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, 1).Value
    DossierCherche = F1.Cells(20, 1).Value
  
    ' Nettoyage de la cellule de résultat
    F1.Cells(1, 2).Clear
  
    ' Lancement de la recherche récursive
    CheminTrouve = TrouverCheminDossier(DossierRacine, DossierCherche)
  
    ' Restitution du résultat
    If CheminTrouve <> "" Then
        ' 1. On écrit le chemin dans la cellule
        F1.Cells(1, 2).Value = CheminTrouve
        F1.Cells(1, 2).Interior.Color = vbGreen
      
        ' 2. BONUS : On ouvre le dossier automatiquement
        ' Le double quote (Chr(34)) est important pour gérer les chemins avec espaces
        Shell "explorer.exe " & Chr(34) & CheminTrouve & Chr(34), vbNormalFocus
      
    Else
        F1.Cells(1, 2).Value = "Non trouvé"
        F1.Cells(1, 2).Interior.Color = vbRed
    End If
  
    F1.Columns("B").AutoFit
    Application.ScreenUpdating = True
End Sub

' Fonction récursive (inchangée)
Function TrouverCheminDossier(DossierPath As String, NomRecherche As String) As String
    Dim Fso As Object
    Dim Dossier As Object
    Dim SousDossier As Object
    Dim Resultat As String
  
    Set Fso = CreateObject("Scripting.FileSystemObject")
  
    On Error Resume Next
    Set Dossier = Fso.GetFolder(DossierPath)
    If Err.Number <> 0 Then Exit Function
    On Error GoTo 0
  
    For Each SousDossier In Dossier.SubFolders
        If SousDossier.Name = NomRecherche Then
            TrouverCheminDossier = SousDossier.Path
            Exit Function
        End If
      
        Resultat = TrouverCheminDossier(SousDossier.Path, NomRecherche)
      
        If Resultat <> "" Then
            TrouverCheminDossier = Resultat
            Exit Function
        End If
    Next SousDossier
End Function

 

[Michou9]

Super
Je viens de tester le code
Cela fonctionne
Je dois partir, je vais tester plus à fond dans mon fichier à mon retour
Mais pour l'instant dans mon fichier exemple, c'est Ok
C'est du costaud !!
Je vais essayer de comprendre si je peux
Je reviendrai ce soir ou demain

Entre temps je venais tout juste de trouver une solution en replaçant "wsSh.Run Chemin" par "Shell "explorer.exe" & " " & Chemin"
Cela fonctionnait bien aussi

Mille mercis

 

[laurent950]

Bonsoir,
Remerciez aussi @sylvanu et tous ceux qui vous ont aidé.
Bonne fin de soirée. 😊

 

[Eric C]

Re le forum, re les intervenants, bonsoir Laurent950

En plus des sages propos de notre ami Laurent (que je salue au passage), il est de bon aloi de "même si tu avais trouvé une solution non signalée jusqu'à présent dans ce post" de cocher (post #35), la solution (sujet résolu) prévue à droite de l'écran et ce afin que d'autres intervenants puissent en prendre bonne note.
Bonne soirée à toutes & à tous.
Eric c
P.S : Sans vous y obliger, pouvez-vous, toutes & tous, "jeter" un coup d'œil sur mon message du forum "Salon de XLD".

 

[patricktoulon]

bonjour
basé sur ma fonction perso (DirPileListDIR) qui utilise une récursivité méthode alternative aux rappels de la fonction elle même
j'ai créé la "DirPileFolderListDIR" qui utilise le même principe
a savoir la récursivité intra collection dans un do/loop

j'avais cré cette alternative a l’époque pour palier a la lourdeur de FSO dans des grandes arborescences de dossiers
pour le coup, la je la transforme en couteau suisse
on peut:

• lister
• chercher un dossier en partant du dossier maitre avec le nom d'un des sub dossier
• chercher un dossier a par tir du dossier maitre avec une partie du nomd'un des sub dossier

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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° Récuperation du chemin complet avec le nom du dossier
'           Folder = DirPileFolderListDIR("chemin dossier maitre", "nom du dossier recherché")
'
'       3° Récuperation du chemin complet avec une partie du nom  du dossier
'           Folder = DirPileFolderListDIR("chemin dossier maitre", "partie nom du dossier recherché")
'------------------------------------------------------------------------------------------------

Option Explicit

Sub testList()
    'Test de récupération complete de la liste des dossier (et leurs sous dossiers)
    Dim ListeFolder
    ListeFolder = DirPileFolderListDIR("K:\vba excel\001 application")
    If IsArray(ListeFolder) Then
        Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
    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("K:\vba excel\001 application", "creatorribbonx IMAGEMSO 2025 V 5 3")
    If Folder <> "" Then MsgBox Folder
End Sub

Sub cherche_un_dossier2()
    'Test de récupération d'un dossier en particulier avec une partie de son nom
    Dim Folder
    Folder = DirPileFolderListDIR("K:\vba excel\001 application", "IMAGEMSO 2025 V 5 3", True)
    If Folder <> "" Then MsgBox Folder
End Sub


Function DirPileFolderListDIR(dossier As String, Optional ShearchFolder As String = vbNullString, Optional part As Boolean = False)
    Dim ItemVU As String, Foldercollection As Collection, CurrentFolder As String, TbL, a As Long, Critere As Long, NameNonConformes As New Collection
    Set Foldercollection = New Collection
    
    ReDim TbL(0) ' Initialisation du tableau
    
    ' S'assurer que le dossier a un backslash final
    If Right(dossier, 1) <> "\" Then dossier = dossier & "\"
    
    ' Ajout du dossier initial dans la pile de dossiers(FolderCollection)
    Foldercollection.Add dossier
    
    ' Parcours de la pile de dossiers
    Do While Foldercollection.Count > 0
        
        'le dossier à explorer c'est toujours le premier de la collection
        CurrentFolder = Foldercollection(1)
        
        'on a determiné currentfolder on peut le supprimer de la pile
        ' on supprime donc le (1)
        Foldercollection.Remove 1
        'on intègre le dossier dans l'array
        a = UBound(TbL) + 1: ReDim Preserve TbL(1 To a): TbL(a) = CurrentFolder
        
        ' Gestion des erreurs pour ignorer les dossiers système ou protégés
        On Error Resume Next
        
        'on fait un dir vbdirectory pour chopper dossiers et fichier
        ItemVU = Dir(CurrentFolder, vbDirectory)
        
        ' Si erreur, on saute ce dossier
        If Err.Number <> 0 Then Err.Clear: GoTo NextFolder
        
        'si itemVu donne un premier path alors on decante ce DIR
        'Parcourir les  dossiers dans le dossier actuel
        Do Until ItemVU = vbNullString
            If Left(ItemVU, 1) <> "." Then
                If (GetAttr(CurrentFolder & "\" & ItemVU) And vbDirectory) = vbDirectory Then
                    If ShearchFolder <> vbNullString And part = False Then If ItemVU = ShearchFolder Then DirPileFolderListDIR = CurrentFolder & ItemVU: Exit Function
                    If ShearchFolder <> vbNullString And part = True Then If ItemVU Like "*" & ShearchFolder & "*" Then DirPileFolderListDIR = CurrentFolder & ItemVU: Exit Function
                    ' Ajouter les sous-dossiers à la pile de dossiers
                    Foldercollection.Add CurrentFolder & ItemVU & "\"
                End If
            End If
            ItemVU = Dir()
        Loop
        
NextFolder:
    Loop
    
    On Error GoTo 0
    ' Retourner le tableau des fichiers
    If ShearchFolder = vbNullString Then DirPileFolderListDIR = TbL
    If NameNonConformes.Count > 0 Then
        Debug.Print "Dossiers avec erreurs: " & NameNonConformes.Count
    End If
End Function

rapidité garantie

Patrick

 

[Michou9]

Bonjour Laurent

Ce code est génial, même plus besoin de paramétrer les sous-dossiers
J'ai fait le test avec 10 sous-dossiers imbriqués
Il trouve le dossier rapidement et sans problème
Puis ensuite l'ouvre, ce que je souhaitais
Le seul petit problème, c'est si on a 2 dossiers identiques
Il ouvre alors le 1er trouvé
Je ne suis pas vraiment concerné, car vu la longueur des noms de mes dossiers, cela à très peu de chance d'arriver
Je dis cela si quelqu'un souhaite utiliser ce code avec des dossiers qui pourraient avoir le même nom
Un grand merci

 

[Michou9]

Bonjour à tous
Je tiens à remercier tous les personnes qui m'ont aidé
Tout particulièrement Sylvanu et Laurent
Mais aussi par la participation de TooFatBoy et Eric C
Je remercie aussi patricktoulon pour sa solution
J'ai commencé à la tester, mais j'ai pas tout compris encore

​

 

[laurent950]

Bonjour @Michou9

le code en Poste #35 ne gére pas les doublon : Un dossier est unique.

Le seul petit problème, c'est si on a 2 dossiers identiques
Il ouvre alors le 1er trouvé

A ) Le code Poste #35 s'arrêtait au premier dossier trouvé, ignorant les doublons.

Autres Code = Autres demande.

B) Demande d'un code gérant les doublons : (Code créer à vous envoyer sur une autre demande)
1 - collecte tous les chemins correspondants sans s'arrêter.
2 - Par défaut, il ouvre automatiquement le premier dossier trouvé.
3 - S'il y a des doublons, il les liste tous à la suite dans la colonne B.
4 - Chaque chemin est un lien cliquable pour ouvrir le dossier de ton choix.

 

[Michou9]

Bonjour Laurent
Si j'ai bien compris vous avez réalisé un code gérant les doublons : (Code créer à vous envoyer sur une autre demande)
Oui cela m'intéresserait beaucoup de le voir

 

[patricktoulon]

Bonjour
a ben je peux mettre une 3eme option pour les doublons si vous voulez
la fonction renverrait allors un array de noms c'est pas un soucis
comme je l'ai dis tel que je l'ai conçu j'en fait ce que je veux

et oui
en l'etat, il suffit de maitre le dossier maitre et le nom ou partie du nom et il le trouve même dans de grande arborescence
ou le sous dossier serait perdu dans une jungle de sous dossier imbriqués
et la méthode est très rapide FSO à coté est loin derrière

 

[laurent950]

Si j'ai bien compris vous avez réalisé un code gérant les doublons

Option Explicit
Option Compare Text

Sub Main()
    Application.ScreenUpdating = False
    
    Dim F1 As Worksheet
    Dim DossierRacine As String
    Dim DossierCherche As String
    Dim Resultats As New Collection
    Dim i As Long
    Dim Fso As Object ' Variable pour l'objet global
    
    Set F1 = Worksheets(ActiveSheet.Name)
    
    ' Création de l'objet UNE SEULE FOIS pour tout le programme (Gain de vitesse)
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    DossierRacine = F1.Cells(1, 1).Value
    DossierCherche = F1.Cells(20, 1).Value
    
    ' Nettoyage de la zone
    F1.Range(F1.Cells(1, 2), F1.Cells(100, 2)).Clear
    
    ' Lancement de la recherche en passant l'objet Fso
    Call TrouverTousLesDossiers(DossierRacine, DossierCherche, Resultats, Fso)
    
    ' --- GESTION DES RÉSULTATS AVEC LIENS ---
    
    If Resultats.Count = 0 Then
        F1.Cells(1, 2).Value = "Non trouvé"
        F1.Cells(1, 2).Interior.Color = vbRed
        
    ElseIf Resultats.Count = 1 Then
        ' Cas unique : Lien + Ouverture auto
        F1.Hyperlinks.Add Anchor:=F1.Cells(1, 2), _
                          Address:=Resultats(1), _
                          TextToDisplay:=Resultats(1)
                          
        F1.Cells(1, 2).Interior.Color = vbGreen
        Shell "explorer.exe " & Chr(34) & Resultats(1) & Chr(34), vbNormalFocus
        
    Else
        ' Cas multiple : Liste + Ouverture auto du 1er
        F1.Cells(1, 2).Value = "Il y a " & Resultats.Count & " dossiers identiques (cliquez pour ouvrir) :"
        F1.Cells(1, 2).Interior.Color = vbYellow
        F1.Cells(1, 2).Font.Bold = True
        
        For i = 1 To Resultats.Count
            F1.Hyperlinks.Add Anchor:=F1.Cells(i + 1, 2), _
                              Address:=Resultats(i), _
                              TextToDisplay:=Resultats(i)
            
            F1.Cells(i + 1, 2).Interior.Color = RGB(220, 240, 220)
            
            If i = 1 Then
                Shell "explorer.exe " & Chr(34) & Resultats(1) & Chr(34), vbNormalFocus
            End If
        Next i
    End If
    
    F1.Columns("B").AutoFit
    Application.ScreenUpdating = True
End Sub

' Fonction récursive optimisée
Sub TrouverTousLesDossiers(DossierPath As String, NomRecherche As String, ByRef ListeResultats As Collection, ByRef Fso As Object)
    Dim Dossier As Object
    Dim SousDossier As Object
    
    On Error Resume Next
    Set Dossier = Fso.GetFolder(DossierPath)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    
    For Each SousDossier In Dossier.SubFolders
        ' Si on trouve, on ajoute à la collection (Rapide, pas de Redim)
        If SousDossier.Name = NomRecherche Then
            ListeResultats.Add SousDossier.Path
        End If
        
        ' On continue l'exploration (Récursivité)
        TrouverTousLesDossiers SousDossier.Path, NomRecherche, ListeResultats, Fso
    Next SousDossier
End Sub