Utilisation de la Fonction DIR dans une double boucle

**Bruno92320** · 15/12/2014, 17h18

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**pgz** · 15/12/2014, 18h39

Bonsoir.

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

Cordialement,

PGZ

**Bruno92320** · 15/12/2014, 19h07

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

**pgz** · 15/12/2014, 20h54

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

**Bruno92320** · 16/12/2014, 00h04

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

**pgz** · 16/12/2014, 10h17

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

Invité · 16/12/2014, 10h25

Bonjour
si ça t'inspires! http://www.developpez.net/forums/d13...r/#post7361484

**Marc-L** · 16/12/2014, 11h49

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 …

Invité · 16/12/2014, 12h01

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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 clsWindowsExporer :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 ClsRep :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Marc-L** · 16/12/2014, 12h15

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

Invité · 16/12/2014, 12h21

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.

**Marc-L** · 16/12/2014, 14h04

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Bruno92320** · 16/12/2014, 14h11

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Marc-L** · 16/12/2014, 15h21

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 !

Invité · 16/12/2014, 16h38

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!

**Marc-L** · 16/12/2014, 17h32

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 …

**Bruno92320** · 16/12/2014, 19h31

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

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é

Bruno

Utilisation de la Fonction DIR dans une double boucle [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager