Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel si exist repertoire dans tout C:

si exist repertoire dans tout C:

2 réponses
Avatar
le_syd1961
Bonjour ...
je voudrais tester l'existence d un ou plusieus repertoire "sport" dans le
disque dur.
j'ai pompé du code a droite a gauche pour faire ca ... mais ca marche pas

Sub testDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Dim folder_txt As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Flder In Dossier.subfolders

folder_txt = Flder.Path
If Left(folder_txt, 4) = "sport" Then
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
End If

Next

'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep

Set fso = Nothing

End Sub 'fs
_____________________________

Sub Test
TestDossiers "C:\", 0
Signaler un problème avec ce contenu

2 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
JB
Bonsoir,


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) = 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

Cordialement JB

Bonjour ...
je voudrais tester l'existence d un ou plusieus repertoire "sport" dans le
disque dur.
j'ai pompé du code a droite a gauche pour faire ca ... mais ca marche p as

Sub testDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Dim folder_txt As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Flder In Dossier.subfolders

folder_txt = Flder.Path
If Left(folder_txt, 4) = "sport" Then
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
End If

Next

'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep

Set fso = Nothing

End Sub 'fs
_____________________________

Sub Test
TestDossiers "C:", 0


Avatar
lSteph
Bonsoir,
'après les commandes lancées dans la fenêtre qui s'ouvre attendre quelques
secondes
'Vraiment just for fun et n'engage que celui qui s'en sert

Sub tstDir()
On Error Resume Next
Workbooks("mylistrep.txt").Close False
On Error GoTo 0
ChDir "c:"
Shell "cmd", 1
Application.Wait Now + TimeValue("00:00:02")
SendKeys "cd c:{enter}", 1
Application.Wait Now + TimeValue("00:00:02")
SendKeys "dir *sport*. /s/b>c:mylistrep.txt{enter}", 1
Application.Wait Now + TimeValue("00:00:15")
SendKeys "exit{enter}", 1
Call ouvre
End Sub
Sub ouvre()
Workbooks.Open "c:mylistrep.txt"
End Sub

'lSteph
"le_syd1961" a écrit dans le message
de news:
Bonjour ...
je voudrais tester l'existence d un ou plusieus repertoire "sport" dans le
disque dur.
j'ai pompé du code a droite a gauche pour faire ca ... mais ca marche pas

Sub testDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Dim folder_txt As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)

' examen du dossier courant
For Each Flder In Dossier.subfolders

folder_txt = Flder.Path
If Left(folder_txt, 4) = "sport" Then
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
End If

Next

'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep

Set fso = Nothing

End Sub 'fs
_____________________________

Sub Test
TestDossiers "C:", 0