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

 

[laurent950]

Bonsoir @patricktoulon

tu pourrais gagner en vitesse, quand tu as trouver le dossier tu sors de la procédure VBA pour évité de tous lister comme j'ai fait