rechercher un répertoire... mais pas dans les sous répertoires

[cach6sous]

bonsoir
j'ai trouvé sur l'excellent site boisgontierj une macro qui permet de chercher un répertoire dans un emplacement donné.
Mon problème: cette macro cherche dans les sous répertoires. Malheureusement je ne comprends pas assez la puissance de fso et je suis incapable de lui dire de ne pas aller fouiller dans les sous répertoires, ce qui dans mon cas rajoute 5 minutes de recherche inutiles car je veux me cantonner au premier niveau du répertoire racine.
Savez-vous comment faire?
Merci d'avance.
Cyril

ci dessous la macro presque parfaite:
Recherche un répertoire (FileSystemObject)

'Cocher Microsoft Scripting RunTime
Dim repCherché
Sub arborescence()
racine = "c:\"
repCherché = InputBox("Nom du répertoire cherché?")
[A:A].Clear
Range("A3").Select
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(racine)
Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)
If UCase(dossier.Name) Like "*" & UCase(repCherché) & "*" Then
ActiveCell.Value = dossier.Path
ActiveCell.Offset(1, 0).Select
End If
On Error Resume Next
For Each d In dossier.SubFolders
Lit_dossier d, niveau + 1
Next
End Sub

 

[Dranreb]

Re : rechercher un répertoire... mais pas dans les sous répertoires

Bonsoir
Il suffit de mettre en commentaire (plutôt que de les supprimer, au cas ou vous en auriez à nouveau un jour besoin) les 4 dernières instructions qui appellent récursivement la procédure Lit_Dossier pour les SubFolders, de On Error Resume Next jusqu'à Next
Cordialement.

 

[cach6sous]

Re : rechercher un répertoire... mais pas dans les sous répertoires

Merci de votre réponse
Je pensais bien que la récursivité se situait par là. Mais en supprimant ces lignes la recherche ne donne plus rien (sauf le répertoire racine).
Avez-vous d'autres idées?
Merci d'avance

 

[Compte Supprimé 979]

Re : rechercher un répertoire... mais pas dans les sous répertoires

Bonjour cach6sous

bonsoir
j'ai trouvé sur l'excellent site boisgontierj une macro qui permet de chercher un répertoire dans un emplacement donné.
Mon problème: cette macro cherche dans les sous répertoires. Malheureusement je ne comprends pas assez la puissance de fso et je suis incapable de lui dire de ne pas aller fouiller dans les sous répertoires, ce qui dans mon cas rajoute 5 minutes de recherche inutiles car je veux me cantonner au premier niveau du répertoire racine
Savez-vous comment faire?

Oui, il suffit d'envoyer un mail à l'EXCELLENT boisgontier
Il se fera un plaisir de te répondre par une jolie phase robotisée ... 🙄

Merci de mettre le code entre balise

Sinon essaye ceci

Sub Lit_dossier(ByRef dossier, ByVal niveau)
  On Error Resume Next
  For Each D In dossier
    If UCase(dossier.Name) Like "*" & UCase(repCherché) & "*" Then
      ActiveCell.Value = dossier.Path
      ActiveCell.Offset(1, 0).Select
    End If
  Next D
  On Error GoTo 0
End Sub

A+

 

[MJ13]

Re : rechercher un répertoire... mais pas dans les sous répertoires

Bonjour à tous

Voir ce fichier à tester (l'enregistrer sur votre DD) 🙂.

 

[cach6sous]

Re : rechercher un répertoire... mais pas dans les sous répertoires

J'espère ne pas dire de bêtise mais lorsque j'utilise ton code (bruno M45) je n'ai plus aucun résultat pour ma recherche (sauf si je cherche le nom du dossier racine)

La proposition de JB fonctionne très bien merci beaucoup

pour le mail, je me disais que vu le nombre de macro dispo sur son site je devais pas être le seul à vouloir faire des adaptations et qu'au bout d'un moment il finirait par envoyer des phrases robotisées 😉

 

[Compte Supprimé 979]

Re : rechercher un répertoire... mais pas dans les sous répertoires

RE,

J'espère ne pas dire de bêtise mais lorsque j'utilise ton code je n'ai plus aucun résultat pour ma recherche (sauf si je cherche le nom du dossier racine)

Je ne comprends donc pas ce que tu souhaites, car au début de ton fil tu as bien indiqué

Mon problème: cette macro cherche dans les sous répertoires... je suis incapable de lui dire de ne pas aller fouiller dans les sous répertoires

Que souhaites-tu exactement !?
Peux tu nous l'expliquer clairement ?

A+

 

[cach6sous]

Re : rechercher un répertoire... mais pas dans les sous répertoires

désolé si je n'ai pas été clair
j'ai un répertoire racine "RACINE"
dedans des répertoires RACINE/REP1, RACINE/REP2, RACINE/REP3, ... RACINE/REPn
je voulais pouvoir identifier REP3 par exemple mais sans aller chercher dans chaque sous répertoire ce qui rallongeait le temps de recherche.

c'est chose faite avec ce code

merci à tous

Dim repCherché
'Dim dateCherché
Sub arborescence()
  racine = "C:\Users\ccachat\Desktop\cca\"
  repCherché = InputBox("Nom du répertoire cherché?")
  'dateCherché = InputBox("Date recherchée?")
  [A:A].Clear
  Range("A3").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.getfolder(racine)
  Lit_dossier_1_Niveau dossier_racine, 1
End Sub

'JB modif brunoM45
Sub Lit_dossier_1_Niveau(ByRef dossier, ByVal niveau)
For Each D In dossier.SubFolders
  If UCase(D) Like "*" & UCase(repCherché) & "*" Then
ActiveCell.Value = D
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub

'brunoM45
'Sub Lit_dossier(ByRef dossier, ByVal niveau)
'  On Error Resume Next
'  For Each D In dossier
'    If UCase(dossier.Name) Like "*" & UCase(repCherché) & "*" Then
'      ActiveCell.Value = dossier.Path
'      ActiveCell.Offset(1, 0).Select
'    End If
'  Next D
'  On Error GoTo 0
'End Sub

'boisgontier
'Sub Lit_dossier(ByRef dossier, ByVal niveau)
'   If UCase(dossier.Name) Like "*" & UCase(repCherché) & "*" & UCase(dateCherché) & "*" Then
'     ActiveCell.Value = dossier.Path
'     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=dossier.Path
'     ActiveCell.Offset(1, 0).Select
'   End If
'   'If UCase(dossier.Name) Like "*" & UCase(dateCherché) & "*" Then
'    ' ActiveCell.Value = dossier.Path
'     'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=dossier.Path
'     'ActiveCell.Offset(1, 0).Select
'   'End If
'   On Error Resume Next
'   For Each D In dossier.subfolders
'      'MsgBox d
'      Lit_dossier D, niveau + 1
'   Next
'End Sub