VBAにて4万個のファイル一覧を書き出したい

質問

ネットで見かけた以下コードで、サブフォルダも含めてファイル一覧を書き出したい。
フォルダに4万個のファイルがあるのですが、すぐにフリーズしてしまいます。
VBAでは大量データを扱うのは無理があるのでしょうか？

Sub TEST7()

Dim A
A = "C:\Users\User\Desktop\DATA"

i = 1
Call TEST8(A, i)

End Sub
Sub TEST8(A, i)

Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")

With ActiveSheet

Dim B
'フォルダ内のファイルをループ
For Each B In FSO.GetFolder(A).Files
i = i + 1
.Cells(i, 1) = A 'フォルダパス
.Cells(i, 2) = B 'ファイルパス
.Cells(i, 3) = FSO.GetFileName(B) 'ファイル名
.Cells(i, 4) = FSO.GetExtensionName(B) '拡張子
.Cells(i, 5) = FSO.GetFile(B).Size 'サイズ
.Cells(i, 6) = FSO.GetFile(B).DateCreated '作成日時
.Cells(i, 7) = FSO.GetFile(B).DateLastModified '更新日時
.Cells(i, 8) = FSO.GetFile(B).DateLastAccessed 'アクセス日時
Next

Dim C
'フォルダ内のサブフォルダをループ
For Each C In FSO.GetFolder(A).SubFolders
i = i + 1
.Cells(i, 1) = C. 'フォルダパス
.Cells(i, 5) = FSO.GetFolder(C).Size 'サイズ
.Cells(i, 6) = FSO.GetFolder(C).DateCreated '作成日時
.Cells(i, 7) = FSO.GetFolder(C).DateLastModified '更新日時
.Cells(i, 8) = FSO.GetFolder(C).DateLastAccessed 'アクセス日時
'再帰する
Call TEST8(C, i)
Next

End With

End Sub

回答No.5

luka3

もう解決したのかもしませんが

再帰を使わないとなると、dirコマンドを活用するのが一番簡単かと思います。
また一度に全部処理せず、二段構えで、まず最初にファイル一覧を取得し、その次にサイズ等の処理をするようにしました。

自分の環境で試したところ、ファイル数約44000で、一覧取得に約10秒、サイズ取得は約30秒で終わりました。
ただ雑多なフォルダで試したので、ファイル名にUnicodeが含まれている部分でエラーが出ました。そのあたりはFSO.FileExistsでチェックして回避すればよいかと。

Sub GetFileList()
Dim objShell As Object
Dim objExec As Object
Dim line As String
Dim A, i, d, dbak

dbak = ""
i = 1
A = "C:\Users\User\Desktop\DATA"

ChDrive A
ChDir A

' WScript.Shell オブジェクトを作成し、dir コマンドを実行
Set objShell = CreateObject("WScript.Shell")
Set objExec = objShell.Exec("cmd /c dir /s /b /a-d")

With ActiveSheet
' 出力を逐一読み取る
Do While Not objExec.StdOut.AtEndOfStream
line = objExec.StdOut.ReadLine
d = Left(line, InStrRev(line, "\") - 1) ' フォルダ名
' フォルダ名の変更があるか
If d <> dbak And dbak <> "" Then
i = i + 1
.Cells(i, 1) = d 'フォルダパス
End If
dbak = d ' フォルダ名を記憶

i = i + 1
.Cells(i, 1) = d 'フォルダパス
.Cells(i, 2) = line 'ファイルパス
.Cells(i, 3) = Mid(line, InStrRev(line, "\") + 1) 'ファイル名
Loop
End With

Set objExec = Nothing
Set objShell = Nothing
End Sub

Sub GetProperty()
Dim FSO As Object
Dim i, f

Set FSO = CreateObject("Scripting.FileSystemObject")

With ActiveSheet
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(i, 2) <> "" Then ' ファイル
Set f = FSO.GetFile(.Cells(i, 2))
.Cells(i, 4) = FSO.GetExtensionName(.Cells(i, 2)) '拡張子
Else ' フォルダ
Set f = FSO.GetFolder(.Cells(i, 1))
End If
.Cells(i, 5) = f.Size 'サイズ
.Cells(i, 6) = f.DateCreated '作成日時
.Cells(i, 7) = f.DateLastModified '更新日時
.Cells(i, 8) = f.DateLastAccessed 'アクセス日時
Set f = Nothing
Next
End With

Set FSO = Nothing
End Sub

回答No.4

SI299792

Dir コマンドが完了するまでプログラムを一時停止させる為のものです。
ファイルサイズが前と違っていたら、Dir が完了していない。この状態で次へ進むと全て拾えない可能性があります。沢山ファイルがあるそうなのであった方がいいと思いました。
私の所では、あっても問題なく動くので、あると動かない理由は解りませんが、無しで動くならない方がいいです。
ここを外した状態でのテストはしていません。

補足

回答ありがとうございます。

もしかして、
Length = FileLen("#.txt")をどこかに書くことが
漏れているとかでしょうか？

回答No.3

SI299792

これ、全項目必要ですか？

リカーシブコールはメモリーを多量に使います。なので、フリーズしたり、メモリー不足で止まります。
対策
・リカーシブコールを使わないようにプログラムを直す（私の力では無理）
・ファイルの取得は、コマンドプロンプトを使う。（以下プログラム）

スピードアップのため、項目を絞ります。
画像の様にB1にフォルダ名を入力して下さい
（プログラムに直接フォルダを書くのは私は嫌いです）
どうしても作成日時やアクセス日時が必要なら、自分で直す・又は補足に書いて下さい（気が向けば直しますが、スピードは若干下がります）
逆に、ファイル名だけでいいなら、もう少し早くできます。
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Option Explicit
'
Sub Macro1()
　　Dim Length As Long
　　Dim ROut As Long
　　Dim RSav As Long
　　Dim FileData As String
'
　　ChDrive [B1]
　　ChDir [B1]
　　Shell "Cmd /C Dir *.* /S > #.txt"
　　Sleep 200
'
　　Do While Length <> FileLen("#.txt")
　　　　DoEvents
　　　　Sleep 100
　　Loop
　　ROut = 3
　　Range("A3:D" & Rows.Count).ClearContents
　　Open "#.txt" For Input As #1
　　Application.ScreenUpdating = False
'
　　Do Until EOF(1)
　　　　Line Input #1, FileData
'
　　　　If FileData Like "*のディレクトリ" Then
　　　　　　Length = Len(FileData)
　　　　　　Cells(ROut, "A") = Mid(FileData, 2, Length - 9)
　　　　　　RSav = ROut
　　　　　　ROut = ROut + 1
　　　　ElseIf Left(FileData, 1) = "2" And Mid(FileData, 22, 1) <> "<" Then
　　　　　　Cells(ROut, "A") = Cells(ROut - 1, "A")
　　　　　　Cells(ROut, "B") = Mid(FileData, 37)
　　　　　　Cells(ROut, "C") = Mid(FileData, 19, 17)
　　　　　　Cells(ROut, "D") = Left(FileData, 17)
　　　　　　ROut = ROut + 1
　　　　ElseIf FileData Like "*バイト" Then
　　　　　　Cells(RSav, "C") = Mid(FileData, 25, 19)
　　　　End If
　　Loop
　　Close
　　Kill "#.txt"
End Sub

補足

回答ありがとうございます。
以下コードを消したら動きました。
このコードは何なのでしょうか？

Do While Length <> FileLen("#.txt")
　　　　DoEvents
　　　　Sleep 100
Loop

回答No.2

chie65536（@chie65535）

ご質問のVBAコードでは、メモリに確保された変数FSOや変数Bや変数Cを、使用後に開放していない為、どんどんメモリを消費していき、メモリの消費量が増えるにつれ、処理が重くなり、フリーズしたようになります。

また、使用したFSOオブジェクトが不要になったら、クローズしないとメモリやリソースを消費します。

以下のように「後始末」を追加してみて、それでも重い（フリーズする）のであれば、VBAは４万個のファイル数には耐えられないのだろうと思われます。

Sub TEST7()

Dim A
A = "C:\Users\User\Desktop\DATA"

i = 1
Call TEST8(A, i)

End Sub
Sub TEST8(A, i)

Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")

With ActiveSheet

Dim B
'フォルダ内のファイルをループ
For Each B In FSO.GetFolder(A).Files
i = i + 1
.Cells(i, 1) = A 'フォルダパス
.Cells(i, 2) = B 'ファイルパス
.Cells(i, 3) = FSO.GetFileName(B) 'ファイル名
.Cells(i, 4) = FSO.GetExtensionName(B) '拡張子
.Cells(i, 5) = FSO.GetFile(B).Size 'サイズ
.Cells(i, 6) = FSO.GetFile(B).DateCreated '作成日時
.Cells(i, 7) = FSO.GetFile(B).DateLastModified '更新日時
.Cells(i, 8) = FSO.GetFile(B).DateLastAccessed 'アクセス日時
Next

Dim C
'フォルダ内のサブフォルダをループ
For Each C In FSO.GetFolder(A).SubFolders
i = i + 1
.Cells(i, 1) = C. 'フォルダパス
.Cells(i, 5) = FSO.GetFolder(C).Size 'サイズ
.Cells(i, 6) = FSO.GetFolder(C).DateCreated '作成日時
.Cells(i, 7) = FSO.GetFolder(C).DateLastModified '更新日時
.Cells(i, 8) = FSO.GetFolder(C).DateLastAccessed 'アクセス日時
'再帰する
Call TEST8(C, i)
Next

set C = Nothing
set B = Nothing

End With
FSO.Close
set FSO = Nothing
End Sub

お礼

回答ありがとうございます。 最初の20行くらい書き出したら止まってしまいます。メモリ不足のようです。

Powered by GRATICA

回答No.1

kkkkkm

こちらのサイトを参考にしてみてはいかがでしょう。
多少変更したら使えるような気がします。

【VBA】フォルダ内のファイル一覧を，サブフォルダも含めて高速に取得する
https://latex-macintosh.hatenablog.com/entry/2019/12/01/011502

お礼

回答ありがとうございます。 dirを使うことがポイントのようですね。コードをいじってみましたが、私の技量では動かなかったのと、別の方がdirを使ったコードを提示していただけたので、そちらでチャレンジしてます。

Powered by GRATICA