teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問エクセルでファイルリストの作成VBAをもっと高速にする方法を教えてください。

編集履歴

回答編集履歴

3

説明修正

2020/10/10 08:34

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -64,17 +64,13 @@
64
64
 
65
65
  全ての行のデータを配列にいれて一気に代入するとさらに高速化できますが、
66
66
 
67
- ハイパーリンクとかは無理なので、ハイパーリンクは後からせっていするとか、
67
+ ハイパーリンクとかは無理なので、ハイパーリンクは後から設定するとかの工夫は必要になります。
68
-
69
- サブフォルダーの部分はサイズが一定しないのであとからするとか、
70
-
71
- の工夫は必要になります。
72
68
 
73
69
 
74
70
 
75
71
  ---
76
72
 
77
- 全ての行のデータを配列にいれて一気に代入する方法をぼちぽち書いていたら、既に他の方から回答がいろいろついてしまいました。
73
+ 全ての行のデータを配列にいれて一気に代入する方法をぼちぼち書いていたら、既に他の方から回答がいろいろついてしまいましたね。
78
74
 
79
75
 
80
76
 
@@ -82,7 +78,9 @@
82
78
 
83
79
  行方向は増やせないし、縦横変換も面倒なので、、、
84
80
 
85
- 10万ファイルを超えるとエラーになります。
81
+ フォルダー単位で書き出してますので、1フォルダー内のファイルが10万を超えるとエラーになります。
82
+
83
+ 手抜きです。
86
84
 
87
85
 
88
86
 
@@ -98,17 +96,17 @@
98
96
 
99
97
  Dim StartRow As Long, ws As Worksheet
100
98
 
101
- Set ws = ThisWorkbook.Worksheets("FileList2")
99
+ Set ws = ThisWorkbook.Worksheets("FileList")
102
100
 
103
101
  StartRow = 3
104
102
 
105
103
 
106
104
 
107
- Fileshow1 Range("B2").Value, StartRow
105
+ Fileshow1 ws.Range("B2").Value, ws, StartRow
108
106
 
109
107
 
110
108
 
111
- With ThisWorkbook.Worksheets("FileList2").Range("B3:B" & StartRow)
109
+ With ThisWorkbook.Worksheets("FileList").Range("B3:B" & StartRow)
112
110
 
113
111
  .Formula = .Value
114
112
 
@@ -156,7 +154,7 @@
156
154
 
157
155
  Dim FileDatas() As String
158
156
 
159
- ReDim FileDatas(1 To 100000, 1 To 8) As String
157
+ ReDim FileDatas(1 To 10000, 1 To 8) As String
160
158
 
161
159
 
162
160
 
@@ -194,7 +192,7 @@
194
192
 
195
193
  If UBound(aSubFolders) > UBound(FileDatas, 2) - 7 Then
196
194
 
197
- ReDim Preserve FileDatas(1 To 100000, 1 To UBound(aSubFolders) + 7)
195
+ ReDim Preserve FileDatas(1 To 10000, 1 To UBound(aSubFolders) + 7)
198
196
 
199
197
  End If
200
198
 
@@ -212,7 +210,9 @@
212
210
 
213
211
 
214
212
 
213
+
214
+
215
- ws.Cells(StartRow, 2).Resize(i, UBound(FileDatas, 2)).Value = FileDatas
215
+ If i > 0 Then ws.Cells(StartRow, 2).Resize(i, UBound(FileDatas, 2)).Value = FileDatas
216
216
 
217
217
 
218
218
 
@@ -222,7 +222,7 @@
222
222
 
223
223
  For Each objSub In objFolder.SubFolders
224
224
 
225
- Fileshow1 objSub.Path, StartRow
225
+ Fileshow1 objSub.Path, ws, StartRow
226
226
 
227
227
  Next
228
228
 

2

コード追記

2020/10/10 08:34

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -69,3 +69,165 @@
69
69
  サブフォルダーの部分はサイズが一定しないのであとからするとか、
70
70
 
71
71
  の工夫は必要になります。
72
+
73
+
74
+
75
+ ---
76
+
77
+ 全ての行のデータを配列にいれて一気に代入する方法をぼちぽち書いていたら、既に他の方から回答がいろいろついてしまいました。
78
+
79
+
80
+
81
+ 配列は10万行固定の無理やりのものです(;^_^A
82
+
83
+ 行方向は増やせないし、縦横変換も面倒なので、、、
84
+
85
+ 10万ファイルを超えるとエラーになります。
86
+
87
+
88
+
89
+ ```vba
90
+
91
+ Sub FolderScript1()
92
+
93
+ Application.Calculation = xlCalculationManual
94
+
95
+ Application.ScreenUpdating = False
96
+
97
+
98
+
99
+ Dim StartRow As Long, ws As Worksheet
100
+
101
+ Set ws = ThisWorkbook.Worksheets("FileList2")
102
+
103
+ StartRow = 3
104
+
105
+
106
+
107
+ Fileshow1 Range("B2").Value, StartRow
108
+
109
+
110
+
111
+ With ThisWorkbook.Worksheets("FileList2").Range("B3:B" & StartRow)
112
+
113
+ .Formula = .Value
114
+
115
+ End With
116
+
117
+
118
+
119
+ Application.Calculation = xlCalculationAutomatic
120
+
121
+ Application.ScreenUpdating = True
122
+
123
+ End Sub
124
+
125
+
126
+
127
+ Public Sub Fileshow1(ByVal strPath As String, ws As Worksheet, ByRef StartRow As Long)
128
+
129
+
130
+
131
+ Dim objSub As Object
132
+
133
+ Dim strList() As String
134
+
135
+
136
+
137
+ Dim rr As Range
138
+
139
+ Dim bb
140
+
141
+ Dim y As Integer
142
+
143
+ Dim col As Integer
144
+
145
+
146
+
147
+ Dim objFso As Object, objFolder As Object
148
+
149
+ Set objFso = CreateObject("scripting.Filesystemobject")
150
+
151
+ Set objFolder = objFso.GetFolder(strPath)
152
+
153
+
154
+
155
+
156
+
157
+ Dim FileDatas() As String
158
+
159
+ ReDim FileDatas(1 To 100000, 1 To 8) As String
160
+
161
+
162
+
163
+ Dim i As Long
164
+
165
+ i = 0
166
+
167
+
168
+
169
+ Dim objFile As Object
170
+
171
+ For Each objFile In objFolder.Files
172
+
173
+ i = i + 1
174
+
175
+ FileDatas(i, 1) = "=HYPERLINK(""" & objFile.Path & """,""" & objFile.Name & """)"
176
+
177
+ FileDatas(i, 2) = objFile.Type
178
+
179
+ FileDatas(i, 3) = Int(objFile.Size / 1024)
180
+
181
+ FileDatas(i, 4) = objFile.DateCreated
182
+
183
+ FileDatas(i, 5) = objFile.DatelastAccessed
184
+
185
+ FileDatas(i, 6) = objFile.DateLastModified
186
+
187
+ FileDatas(i, 7) = objFile.ParentFolder.Path
188
+
189
+
190
+
191
+ Dim aSubFolders, aSubFolder
192
+
193
+ aSubFolders = Split(FileDatas(i, 7), "\")
194
+
195
+ If UBound(aSubFolders) > UBound(FileDatas, 2) - 7 Then
196
+
197
+ ReDim Preserve FileDatas(1 To 100000, 1 To UBound(aSubFolders) + 7)
198
+
199
+ End If
200
+
201
+
202
+
203
+ Dim c As Long
204
+
205
+ For c = 1 To UBound(aSubFolders)
206
+
207
+ FileDatas(i, c + 7) = aSubFolders(c)
208
+
209
+ Next
210
+
211
+ Next
212
+
213
+
214
+
215
+ ws.Cells(StartRow, 2).Resize(i, UBound(FileDatas, 2)).Value = FileDatas
216
+
217
+
218
+
219
+ StartRow = StartRow + i
220
+
221
+
222
+
223
+ For Each objSub In objFolder.SubFolders
224
+
225
+ Fileshow1 objSub.Path, StartRow
226
+
227
+ Next
228
+
229
+
230
+
231
+ End Sub
232
+
233
+ ```

1

コード微修正

2020/10/10 08:07

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -54,7 +54,7 @@
54
54
 
55
55
  Array(objFile.Type, Int(objFile.Size / 1024), objFile.DateCreated, _
56
56
 
57
- objFile.DatelastAccessed, objFile.DateLastModified, objFile.ParentFolder.Path)
57
+ objFile.DatelastAccessed, objFile.DateLastModified, objFile.ParentFolder.Path)
58
58
 
59
59
  ```
60
60