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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
| Function FolderFiles(strFolderName As String, Num_Detail As Integer, Optional bFoldersDetail As Long = 0, Optional bIncludeSubfolders As Boolean = True) As Variant()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Need to activate the reference Microsoft Scripting RunTime, to do in case of error and have ListFilesInFolder Sub Available '
' To be used this way '
' Dim Files() As Variant '
' Files = FolderFiles(Folder_To_Search, 6, 0, True) or in this case simply Files = FolderFiles(Folder_To_Search, 6) '
' 2th parameter from 1 to 10 is the number of columns informations to get. From 1 to 6 is about same performance, from 7 it's quite slower '
' 3th parameter to false if you only want to list on the folder and not it subfolders, by default to True '
' 4th parameter to define which folders you want detailled informations, 0 => No one, 1 => Only empty Folders, 2 => All, if other same as 0(Default)'
' The resulting array is sorted in a kind of binary sort that may not suit you (for example Z < a < e < ê '
' '
' From Excel 2021 or Office 365 you can do Files = WorksheetFunction.Sort(FolderFiles(Folder_To_Search, 6), Array(1, 2)) to sort in a more text sort'
' Unfortunately it convert Date(VarType=7) to String(VarType=8) causing (if not using US Date Format) date and month inversion when pasting to excel'
' To avoid this Date are below converted to Double. Up to you to do later a CDate or choose date format if you paste to Excel '
' Also it convert one row array in one dimension array, to avoid this a second row is added to the result if there is only one '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Files_List() As Variant, transpose() As Variant
Dim B_Inf As Long, B_Sup As Long, B_Inf2 As Long, B_Sup2 As Long
Dim i As Long, j As Long
Call ListFilesInFolder(Files_List, strFolderName, Num_Detail, True, bFoldersDetail, bIncludeSubfolders)
Application.StatusBar = False
' Transpose the resulting array to have files in lines and property in columns
' Slightly faster than Application.transpose and limited to 65536 lines
B_Inf = LBound(Files_List, 1)
B_Sup = UBound(Files_List, 1)
B_Inf2 = LBound(Files_List, 2)
B_Sup2 = UBound(Files_List, 2)
If B_Inf2 = B_Sup2 Then
' If there is only one row, adding a second row (Empty) to avoid WorksheetFunction.Sort generating a 1D Array
ReDim transpose(B_Inf2 To B_Sup2 + 1, B_Inf To B_Sup)
Else
ReDim transpose(B_Inf2 To B_Sup2, B_Inf To B_Sup)
End If
' Browse the table and copy
For i = B_Inf To B_Sup
For j = B_Inf2 To B_Sup2
' Conversion of date into Double as WorksheetFunction.Sort does not manage it correctly
If VarType(Files_List(i, j)) = vbDate Then ' vbDate = 7
transpose(j, i) = CDbl(Files_List(i, j))
Else
transpose(j, i) = Files_List(i, j)
End If
Next j
Next i '
FolderFiles = transpose
End Function
Sub ListFilesInFolder(Files_List() As Variant, strFolderName As String, Num_Detail As Integer, bUpperCall As Boolean, Optional bFoldersDetail As Long = 0, Optional bIncludeSubfolders As Boolean = True)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Adapted from https://www.developpez.net/forums/d200523/logiciels/microsoft-office/excel/contribuez/lister-fichiers-d-repertoire-feuille-excel/ '
' Need to activate the reference Microsoft Scripting RunTime, to do in case of error '
' To be used this way '
' Dim Files() As Variant '
' Call ListFilesInFolder(Files, Folder_To_Search, 6, True, True, 0) '
' 3th parameter from 2 to 10 is the number of columns informations to get. From 2 to 6 is about same performance, from 7 it's quite slower '
' 4th parameter alway put true for the original call, false only inside this script '
' 5th parameter to false if you only want to list on the folder and not it subfolders '
' 6th parameter to define which folders you want detailled informations, 0 => No one, 1 => Only empty Folders, 2 => All, if other same as 0 '
' As "ReDim Preserve" works only on last dimension the resultint array is inverted, files are in columns, informations in line '
' To get proper Array result you can apply Application.Tranpose or better (faster and avoid lines/columns limit) any Transpose function of you own'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Browse of the folder
Static FSO As FileSystemObject
Dim oSourceFolder As Scripting.Folder, oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim FolderText As String
' Static bNotFirstTime As Boolean defining it here was problematic when re-executing, so we pass it as a parameter
Static i As Long
Dim j As Long
' Forcing Num_Detail to 2 if lower
If Num_Detail < 2 Then
Num_Detail = 2
End If
' If Not bNotFirstTime Then
If bUpperCall Then
Set FSO = CreateObject("Scripting.FileSystemObject")
i = 0
'bNotFirstTime = True
End If
On Error GoTo ErrorHandler
' Testing if no right issue to scan the folder
If Dir(strFolderName, vbDirectory) = "" Then
i = i + 1
ReDim Preserve Files_List(1 To Num_Detail, 1 To i)
If Num_Detail >= 1 Then
Files_List(1, i) = strFolderName
End If
If Num_Detail >= 2 Then
Files_List(2, i) = "####No rights to scan Folder or it does not exist: " & strFolderName
End If
Else ' Scanning the folder
Set oSourceFolder = FSO.GetFolder(strFolderName)
' Folder treatment if bFoldersDetail = 2 or if bFoldersDetail = 1 and folder is empty (no files, no subfolders)
If bFoldersDetail = 2 Or (bFoldersDetail = 1 And (oSourceFolder.Files.Count + oSourceFolder.SubFolders.Count) = 0) Then
i = i + 1
ReDim Preserve Files_List(1 To Num_Detail, 1 To i)
If Num_Detail >= 1 Then
j = 1
Files_List(1, i) = oSourceFolder.Path ' "Folder path"
End If
If Num_Detail >= 2 Then
j = 2
If oSourceFolder.Files.Count + oSourceFolder.SubFolders.Count = 0 Then
Files_List(2, i) = "#<Empty Folder>"
Else
Files_List(2, i) = "#<" & oSourceFolder.SubFolders.Count & " subfolders, " & oSourceFolder.Files.Count & " files>"
End If
End If
If Num_Detail >= 3 Then
j = 3
Files_List(3, i) = oSourceFolder.Size ' "Size"
End If
If Num_Detail >= 4 Then
j = 4
Files_List(4, i) = oSourceFolder.DateLastModified ' "Date last modified"
End If
If Num_Detail >= 5 Then
j = 5
Files_List(5, i) = oSourceFolder.DateCreated ' "Date created"
End If
If Num_Detail >= 6 Then
j = 6
Files_List(6, i) = oSourceFolder.DateLastAccessed ' "Date last accessed"
End If
If Num_Detail >= 7 Then
j = 7
Files_List(7, i) = oSourceFolder.Type ' "Type"
End If
If Num_Detail >= 8 Then
j = 8
Files_List(8, i) = oSourceFolder.Attributes ' "Attributes"
End If
If Num_Detail >= 9 Then
j = 9
Files_List(9, i) = oSourceFolder.ShortPath ' "Short path"
End If
If Num_Detail >= 10 Then
j = 10
Files_List(10, i) = oSourceFolder.ShortName ' "Short name"
End If
j = 0
If i Mod 100 = 0 Then
Application.StatusBar = "Get files list : " & i & " files/folder had been listed."
End If
End If ' End of Folder treatment
' Files treatment
For Each oFile In oSourceFolder.Files
i = i + 1
ReDim Preserve Files_List(1 To Num_Detail, 1 To i)
'Files_List(0, i) = oFile.Path ' "Full path"
If Num_Detail >= 1 Then
j = 1
Files_List(1, i) = oFile.ParentFolder.Path ' "Parent folder"
End If
If Num_Detail >= 2 Then
j = 2
Files_List(2, i) = oFile.Name ' "File name"
End If
If Num_Detail >= 3 Then
j = 3
Files_List(3, i) = oFile.Size ' "Size"
End If
If Num_Detail >= 4 Then
j = 4
Files_List(4, i) = oFile.DateLastModified ' "Date last modified"
End If
If Num_Detail >= 5 Then
j = 5
Files_List(5, i) = oFile.DateCreated ' "Date created"
End If
If Num_Detail >= 6 Then
j = 6
Files_List(6, i) = oFile.DateLastAccessed ' "Date last accessed"
End If
If Num_Detail >= 7 Then
j = 7
Files_List(7, i) = oFile.Type ' "Type"
End If
If Num_Detail >= 8 Then
j = 8
Files_List(8, i) = oFile.Attributes ' "Attributes"
End If
If Num_Detail >= 9 Then
j = 9
Files_List(9, i) = oFile.ShortPath ' "Short path"
End If
If Num_Detail >= 10 Then
j = 9
Files_List(10, i) = oFile.ShortName ' "Short name"
End If
j = 0
If i Mod 100 = 0 Then
Application.StatusBar = "Get files list : " & i & " files/folder had been listed."
End If
Next oFile
If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.SubFolders
Call ListFilesInFolder(Files_List, oSubFolder.Path, Num_Detail, False, bFoldersDetail, bIncludeSubfolders)
Next oSubFolder
End If
End If
' Resetting the progress bar
If bUpperCall Then
Application.StatusBar = False
End If
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
If j = 0 Then
i = i + 1
ReDim Preserve Files_List(1 To Num_Detail, 1 To i)
If Num_Detail >= 1 Then
Files_List(1, i) = strFolderName
End If
If Num_Detail >= 2 Then
Files_List(2, i) = "<Impossible to scan Folder: " & strFolderName & ">"
End If
Else
Files_List(j, i) = "####Erreur: " & Err.Number & " ; " & Err.Description
End If
Resume Next
End Sub |
Lister les fichiers d'un répertoire dans une feuille Excel
quand vous avez obtenu ou trouvé vous-même la réponse à votre question.
Répondre avec citation
Envoyé par AlainTech
Tutoriel :
Partager