Utilisation de la Fonction DIR dans une double boucle

Version imprimable

Bonjour,

Je me permet de vous embêter, je suis à ma limite de compétence ...
Cette macro est dans un Fichier Excel, elle devrait copier dans un onglet du fichier en question tous les fichiers et sous-fichiers qui sont au même endroit que le fichier en question.

Mon problème est le second DIR.
Le premier fonctionne parfaitement, il me permet de lister le premier dossier et tous les sous-dossiers ...
Mais dès que je sors de la première boucle le second DIR est perdu ...

Je pense qu'il faut que je lui explique ou chercher... mais si je remet le chemin initial, ça tourne en boucle.

J'espère être compréhensible.
Merci pour ceux qui me comprendront :)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 Sub Test() 'cette fonction permet de mettre à jour la structure du serveur en comptant et écrivant les fichiers et les sous-fichiers Dim myPath, myFile, myFileCA As String myPath = ThisWorkbook.Path myFile = Dir(myPath & "\", vbDirectory) R = 1 S = 1 Do While myFile <> "" If myFile <> "." And myFile <> ".." Then myFileCA = Dir(myPath & "\" & myFile & "\", vbDirectory) Do While myFileCA <> "" If myFileCA <> "." And myFileCA <> ".." Then Sheets("Organisation").Select Cells(S + R, 2) = myFileCA Cells(S + R, 1) = myFile S = S + 1 End If myFileCA = Dir() Loop R = R + 1 End If myFile = Dir() Loop End Sub

15/12/2014, 18h39
pgz

Bonsoir.

Quand tu sors de la boucle, tu veux alors chercher dans quel dossier?

Cordialement,

PGZ
15/12/2014, 19h07
Bruno92320

Bonsoir,

Merci pour ta réponse.

j'ai une boucle extérieure qui devrait s'occuper des dossiers et une boucle intérieure qui s'occupe des sous-dossiers.
Quand je sors de la boucle intérieure, j'ai besoin de revenir aux dossiers.

Par exemple si j'ai un Dossier : "Dossier 1" qui a 2 sous-dossiers : "SousDossier1" et "SousDossier2" : ça fonctionne nikel
Mais si j'ai aussi : "Dossier 2" ... le DIR est toujours dans les sous-Dossier du "Dossier 1".

Je n'arrive pas à lui demander de passer au "Dossier 2".

Chapeau si tu trouves la solution.
JE suis désolé j'essaye d'expliquer clairement mais je galère :D
15/12/2014, 20h54
pgz

Re,

Tu veux juste lister les fichiers et sous-dossier de premier niveau ou tu veux explorer toute l'arborescence des sous-dossiers ?
Tu veux écrire quoi dans les colonnes 1 et 2?

PGZ
16/12/2014, 00h04
Bruno92320

Effectivement c'est une bonne question :)

Dans la colonne 1 j'écris les dossiers
Dans la colonne 2 j'écris les sous-dossiers

Merci de te pencher sur mon cas :)
16/12/2014, 10h17
pgz

Bonjour.

Il y avait 2 questions. Il reste :
Tu veux juste lister les fichiers et sous-dossier de premier niveau ou tu veux explorer toute l'arborescence des sous-dossiers ?

Cordialement,
PGZ
16/12/2014, 10h25
Invité

Bonjour
si ça t'inspires! http://www.developpez.net/forums/d13...r/#post7361484
16/12/2014, 11h49
Marc-L

Salut Robert !

Dans ton lien tu évoques la fonction Dir ayant une mémoire de poisson ! (Je n'ai pas vu voir ton code …)

Je ne suis pas tout à fait d'accord en utilisant une procédure récursive, si, si, cela marche !
Souvent plus rapide que FSO mais plus compliqué à mettre en œuvre, d'où le succès de FSO …

FSO a aussi un autre avantage pour certains répertoires spéciaux (system par exemple)
ou des noms de fichiers avec des caractères hors norme …

Bonjour Marc;
je confirme quand tu quitte la procédure récursive, le dir mélange les répertoire et ne sais plus ou il habite.
tu vas te retrouver avec un mélange de répertoires bizarroïde!
C:\Program File\mes document ou que sais je.
je l'ai vérifié a plusieurs reprise en regardant des poste sur ce forum!
ça fonctionne tant que l'on descend dans arborescence quand il s'agit puis remonter puis redescendre dans une autre branche!!!!!

Code:

1
2
3
4
5
6
7
8
9
10
 
sub test
MyDir "c:\"
end sub
Sub MyDir(Racine)
t=dir(racine)
while t<>""
 if t=rep then MyDir t
wend
end sub

Citation:

Envoyé par Marc-L

Salut Robert !

Dans ton lien tu évoques la fonction Dir ayant une mémoire de poisson ! (Je n'ai pas vu voir ton code …)

Je ne suis pas tout à fait d'accord en utilisant une procédure récursive, si, si, cela marche !
Souvent plus rapide que FSO mais plus compliqué à mettre en œuvre, d'où le succès de FSO …

FSO a aussi un autre avantage pour certains répertoires spéciaux (system par exemple)
ou des noms de fichiers avec des caractères hors norme …

en ce qui concerne le Fso je suis d'accords avec toi plus lent plus compliqué! mais su tu garde tes routines!
moi je n'utilise que Fso il gère bien le réseau tu peux tester un fichier en réseau même si le câble est débranché.
je concatène toutes mes routine dans un module de classe et hop!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = fso.FolderExists(Repertoires)
Set fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim fso
Dim Rep
Set fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
Function Repertoire_Date_Creation(Repertoire)
  Dim fso
Dim Rep
Set fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = fso.GetFolder(Repertoire)
    Repertoire_Date_Creation = Rep.DateCreated
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim t
Dim R
Dim I
R = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t) - 1
    If Trim("" & t(I)) <> "" Then
        R = R & Trim("" & t(I))
        If Repertoires_Existe(R) = False Then fso.CreateFolder "" & R
    End If
     R = R & "\"
Next
Set fso = Nothing
End Sub
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFolder Source, Destination, True
Set fso = Nothing
End Sub
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Function Deplace_Repertoire(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fso.MoveFolder Source, Destination
If Err > 0 Then Deplace_Repertoire = Err.Description
Err.Clear
On Error GoTo 0
Set fso = Nothing
End Function
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder DelRepertoire, True
Set fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim fso
Dim Fich
Set fso = CreateObject("Scripting.FileSystemObject")
Set Fich = fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = fso.FileExists(Fichier)
Set fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier)
Dim fso
If Fichier_Exist(Fichier) = True Then
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = fso.GetBaseName(Fichier)
Set fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier)
Dim fso
If Fichier_Exist(Fichier) = True Then
Set fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = fso.GetExtensionName(Fichier)
Set fso = Nothing
End If
End Function
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile Source, Destination, True
Set fso = Nothing
End Sub
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source, Destination)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile Source, Destination
Set fso = Nothing
End Sub
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier)
If Fichier_Exist(DelFichier) = True Then
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile DelFichier, True
Set fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim fso, NewFichier
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(sFile, 8)
NewFichier.Write sText
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Function
Public Sub FichierLog(sFile, txt)
Dim FichierLog, fso
FichierLog = sFile
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
AppendTxt FichierLog, txt
Set fso = Nothing
End Sub
Private Sub EnteteFichier(Fichier)
Dim txt, fso, NewFichier
txt = "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & ""
txt = txt & vbCrLf
txt = txt & "   Date de création: " & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Time) & ":" & Minute(Time) & vbCrLf
txt = txt & vbCrLf
txt = txt & "   " & Fichier
txt = txt & vbCrLf
txt = txt & "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & vbCrLf
txt = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Sub

voici le code dans l'exemple du lien

Code:

1
2
3
4
5
6
7
8
9
10
Public Feuille As Worksheet
Public L As Long
Sub test()
Dim t As New ClsRep
Dim Classeur As Workbook
Set Classeur = Application.Workbooks.Add
Set Feuille = Classeur.Worksheets(1)
t.ScanRep "C:\Documents and Settings\rdurupt\Bureau"
 
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Dim MesRep(), Fso, Name, Rep, SousRep, SubClsRep, IndexRep
 
Private Sub Class_Initialize()
Set Fso = CreateObject("Scripting.FileSystemObject")
End Sub
Public Sub ScanRep(RepRacine)
    If Fso.FolderExists(RepRacine) Then
         Name = RepRacine
           Set Rep = Fso.GetFolder(RepRacine)
           TestFile Rep
         For Each SousRep In Rep.SubFolders
            IndexRep = IndexRep + 1
            ReDim Preserve MesRep(IndexRep)     'Tableau de sous répertoires.
            Set SubClsRep = New ClsRep
            Set MesRep(IndexRep) = SubClsRep
            Set SubClsRep = Nothing
            MesRep(IndexRep).ScanRep SousRep.Path   'Effectue un scanne du sous répertoire détecté.
            Next
 
    End If
 
     End Sub
Private Sub TestFile(Rep)
       Dim ListFichiers, MonFich
 
    Set ListFichiers = Rep.Files
     For Each MonFich In ListFichiers       'Scanne les Fichiers.
 
        If InStr(1, UCase(Fichier_extension(MonFich.Path)), "XLS") <> 0 Then
            L = L + 1
            Feuille.Cells(L, 1) = MonFich.Path
        End If
    DoEvents
     Next
 
     End Sub
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function

16/12/2014, 12h15
Marc-L

Non, je n'ai jamais eu ce problème mais mon code était bien plus étoffé !
Je l'ai testé sur des partitions complètes, la différence avec FSO se portait juste sur les cas spéciaux.
A l'occasion, je le posterais une fois retrouvé et retesté, sait-on jamais …

Et j'affirme le contraire : FSO plus simple que Dir (pas sûr du coup que ce soit vraiment en récursif) …
16/12/2014, 12h21
Invité

oui bien sur, je ne demande qu'a être convaincus.

ceci dit je confirme ce que tu disais plus haut;FSO est plus lent et plus délicat à mettre en oeuvre.

Non, encore une fois, j'affirme le contraire ‼
FSO plus facile à mettre en œuvre que la fonction Dir pour scanner des sous-répertoires, d'où le succès de FSO …

J'ai retrouvé un classeur de tests mais j'ai l'embarras car je n'arrive pas à reproduire le pourquoi d'une sécurité
dans les versions avec une variable tableau globale ou avec la collection ArrayList, donc ce sera la plus simple …

La procédure Demo appelle la liste des fichiers *.xl* à partir de la racine de la partition D via la procédure "récursive" DirScan.
Cette dernière utilise la procédure DirList pour afficher les fichiers d'un répertoire dans la colonne C
et pour scanner ses dossiers.

Code à coller dans le module d'une feuille de test :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Const COL = 3
 
 
Function DirList(SCAN$, Optional FOLD$, Optional ATTR As VbFileAttribute = vbNormal) As String()
         Dim T$()
 
         With Application
             If FOLD > "" Then
                 If Right(FOLD, 1) <> .PathSeparator And Left(SCAN, 1) <> .PathSeparator Then _
                        FOLD = FOLD & .PathSeparator
                 D$ = FOLD
 
             Else
                 D = Left$(SCAN, InStrRev(SCAN, .PathSeparator))
             End If
         End With
 
         If SCAN = "." Then SCAN = "*."
         On Error Resume Next
         F$ = Dir(FOLD & SCAN, ATTR)
 
         Do Until F = ""
             If ATTR And vbDirectory Then _
                B% = Right(F, 1) = "." Or (GetAttr(D & F) And vbDirectory) = 0
 
             If B = 0 Then U& = U& + 1: ReDim Preserve T(1 To U): T(U) = FOLD & F
             F = Dir
         Loop
 
         DirList = IIf(U, T, Split(""))
End Function
 
 
Sub DirScan(WHAT$, ByVal FROM$)
    DL = DirList(WHAT, FROM)
 
    If UBound(DL) > 0 Then _
       Cells(Rows.Count, COL).End(xlUp)(2).Resize(UBound(DL)).Value = Application.Transpose(DL)
 
    For Each DL In DirList("*", FROM, vbDirectory):  DirScan WHAT, DL:  Next
End Sub
 
 
Sub Demo()
    Const FIC$ = "*.xl*", SRC$ = "D:\"
    Me.UsedRange.Clear
    Application.ScreenUpdating = False
    Cells(COL).Value = "Exploration de " & SRC & FIC & " :"
    DirScan FIC, SRC
    Columns(COL).AutoFit
End Sub

Qu'en pensez-vous ?

Un grand merci pour vos retour.

J'ai donc abandonné la fonction DIR qui comme le fait remarquer rdurupt galère quand tu l'utilise à plusieurs niveaux.
J'ai réalisé une première fonction qui me permet d'identifier le chemin de recherche :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub Test2() Dim FileSystem As Object Dim HostFolder As String R = 1 HostFolder = ThisWorkbook.Path Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(HostFolder & "\") End Sub
et une seconde qui me permet d'aller cherhce les dossier et les sous-dossiers :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub DoFolder(Folder) Dim SubFolder For Each SubFolder In Folder.SubFolders Sheets("Organisation").Select Cells(1 + R, 1) = Folder.Name Cells(1 + R, 2) = SubFolder.Name DoFolder SubFolder R = R + 1 Next End Sub
Vous en pensez quoi les experts ?
Ca vous semble robuste ?
Des idées d'amélioration ...
En tout cas ça fonctionne pas mal !

Merci les gars

Bonjour,

dans la procédure Test2 la ligne de code n°7 ne sert à rien !

Dans la procédure DoFolder la ligne n°10 doit être déplacée avant la ligne n°8,
inutile de sélectionner la feuille de calculs à chaque itération, une fois devrait suffire !

Et de mon côté ton code me renvoie un message d'erreur 70 Permission refusée :
normal car au moins un répertoire est verrouillé par le système, l'anti-virus, …

Par contre je n'ai pas ce souci avec la fonction DirList de mon précédent message !
La copier puis ajouter le code suivant et lancer la procédure Demo :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub DirDossiers(ByVal FROM$) DL = DirList(FROM, , vbDirectory) If UBound(DL) > 0 Then With Cells(Rows.Count, 2).End(xlUp)(2).Resize(UBound(DL)) .Offset(, -1).Value = FROM .Value = Application.Transpose(DL) End With For Each V In DL: DirDossiers FROM & V & "\": Next End If End Sub Sub Demo() Worksheets("Organisation").Activate Cells(1).CurrentRegion.Columns(1).Resize(, 2).Clear Application.ScreenUpdating = False DirDossiers IIf(ThisWorkbook.Path = "", CurDir, ThisWorkbook.Path) & "\" Cells(1).CurrentRegion.Columns(1).Resize(, 2).AutoFit End Sub
Comme quoi quand la fonction Dir est maitrisée …

Sinon en réseau je plussoie Robert : préférer FSO !

16/12/2014, 16h38
Invité

Marc je suis bluffé! ton procès est beaucoup plus rapide que le mien! à améliorer quand même (mais je pense que c'est jouable) il me retourne 671 fichier .Xl* et le mien 698 le tien 1 seconde le mien j'ai honte je ne dirai pas mon age!
16/12/2014, 17h32
Marc-L

Pas de souci Robert car je connais bien le sujet : j'utilise cette manière depuis environ dix ans !
Tu comprends maintenant pourquoi je m'évertue à crier la rapidité de Dir mais un peu contre le vent …
Je l'ai déjà évoqué maintes fois sur ce forum entre autres, signalant par exemple une procédure FSO de 2'15
contre moins de vingt secondes côté Dir … Attention, le cache joue énormément en faveur de Dir !

J'ai même pensé à une contribution mais vu l'attitude générale vis à vis de la fonction Dir (quel que soit le forum du reste),
ayant vu déjà au moins trois contributions sur le sujet dans ce forum et suite à un résultat inexpliqué où pour une fois,
sans cache, FSO a devancé Dir, pas eu le temps d'approfondir, j'ai abandonné …

La différence entre la fonction Dir et FSO est que par défaut FSO cherche dans tous les types de dossiers : cachés, système, …
donc c'est plus long et c'est pour partie la raison de fichiers supplémentaires côté FSO.
En jouant donc sur les paramètres de la fonction Dir, cela doit se lisser quelque peu …
16/12/2014, 19h31
Bruno92320

Merci les gars

Un grand merci Marc pour ta proposition.

Elle fonctionne parfaitement.
Je suis en train d'essayer de comprendre comment elle fonctionne... c'est bien au dessus de mes capacités, tu utilises plein de fonctions que je ne connais pas 8O

Je fais du débogage pas à pas pour comprendre chaque étape... mais même comme ça ce n'est pas très clair.

En tout cas un grand merci :)
Et je suis super impressionné :P

Bruno