ファイル容量自動取得VBA

Question

実現したいこと

所定フォルダのファイル容量を取得し、Excelへ書込むプログラムの高速化をしたいと考えております。
お力添えをお願いします。

●現状
所定フォルダのファイル容量を取得し、Excelへ書込むプログラムを作成しました。
内容：フォルダのフルパスをVBAコードへ入力し、ボタン実行すると、Excelへ取得情報を書き込む

発生している問題

プログラムは作成し動作はすのですが、以下問題が発生
ファイル数が200以上ある場合、処理に時間を要してしまいます。

該当のソースコード

Private Sub btnAction_Click()
    strPath = "C:\" '対象フォルダのフルパス入力
    shtFile.Cells(8, 2) = " "
    Range("A8", ActiveCell.SpecialCells(xlLastCell)).ClearContents
    Range("A8").Select
    i = 8
    FileDisp strPath, i
End Sub

Private Sub FileDisp(strPath, i)
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFld = objFs.GetFolder(strPath)
    For Each objFl In objFld.Files
        shtFile.Cells(i, 2) = objFs.GetBaseName(objFl.Path)
        shtFile.Cells(i, 3) = objFl.ParentFolder.Path
        shtFile.Cells(i, 4) = Int(objFl.Size / 1024)
        shtFile.Cells(i, 5) = objFl.Type
        i = i + 1
    Next
    For Each objSub In objFld.SubFolders
        FileDisp objSub.Path, i
    Next
    Range("J2") = Date
    
End Sub

###追加△1
●以下フォルダパスで実行したところ、以下取得できないフォルダ、ファイルが発生してしまいました。１つのケースを抜粋させていただきます。
対象フォルダには、QR自動作成VBAフォルダ※格納ファイル：QRコード作成.xlsm
があるのですが、実行結果には記載されていませんでした。

●対象フォルダ：C:\Users\苗字\Desktop\名前\00_VBA※苗字、名前は自分の名前の為、伏せさせていただきます。

●実行結果

詳細

###追加△2
回答者のhatena19さんのやり方をトライしたのですが、一部取得出来ない為改めて相談させていただきます。

Answer 1

Excel VBA の高速化の定番としては以下２点が挙げられます。

(1) 画面の描画を抑止する

処理開始時に Application.ScreenUpdating を False、終了時に True にします。

(2) 配列を使用する

Dim va(1, 1) As Variant
va(0, 0) = "A"
va(0, 1) = 1
va(1, 0) = "B"
va(1, 1) = 2
Range("A1:B2").Value = va

のような感じで複数のセルを一括で代入できます。

あとは細かいことですが

(3) Option Explicit を記述し、変数宣言を必須にする
(4) 変数や引数の型を明示する
(5) Microsoft Scripting Runtime を参照設定し、アーリーバインドする
(6) フォルダがネストしたとき Scripting.FileSystemObject が複数インスタンス化されるので、最初にインスタンス化し、引数で渡すかモジュール変数にしてしまう
(7) Range("J2") = Date が複数回実行される可能性がある
(8) ファイルサイズは Int だと桁数が不安なので CLng のほうが良いかも

といったところです。

Comments

[jabe]

ご回答ありがとうございます。
高速化のポイントたくさんあるんですね、知らなかったです。
勉強してみます。

Answer 2

高速化の対策は、KOZ6.0さんの回答で指摘されている通りです。

それをもとにコード化すると下記のような感じになるでしょう。

Option Explicit

Private Sub btnAction_Click()
    Application.ScreenUpdating = False

    Dim strPath As String:  strPath = "C:\Test"  '対象フォルダのフルパス入力
    Dim shtFile As Worksheet:  Set shtFile = ActiveSheet
    shtFile.Cells(8, 2) = " "
    shtFile.Range("A8", ActiveCell.SpecialCells(xlLastCell)).ClearContents
    
    Dim i As Long: i = 8
    Dim objFs As New FileSystemObject

    FileDisp objFs, strPath, i, shtFile
    
    shtFile.Range("J2") = Date
    Set objFs = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub FileDisp(objFs As FileSystemObject, strPath As String, i As Long, shtFile As Worksheet)
    Dim objFld As Folder: Set objFld = objFs.GetFolder(strPath)
  
    Dim aryFl()
    If objFld.Files.Count > 0 Then
        ReDim aryFl(1 To objFld.Files.Count, 1 To 4)
        Dim objFl As File, j As Long
        For Each objFl In objFld.Files
            j = j + 1
            aryFl(j, 1) = objFs.GetBaseName(objFl.Path)
            aryFl(j, 2) = objFl.ParentFolder.Path
            aryFl(j, 3) = Int(objFl.Size / 1024)
            aryFl(j, 4) = objFl.Type
        Next
        shtFile.Cells(i, 2).Resize(j, 4).Value = aryFl
    End If
    
    For Each objFld In objFld.SubFolders
        FileDisp objFs, objFld.Path, i + j, shtFile
    Next
End Sub

VBAウィンドウの[ツール]→[参照設定]で
Microsoft Scripting Runtime
にチェックを入れておく。

ちなみに、Intは小数点以下を切り捨て、CLngは小数点以下を丸める、といった違いがあります。
Intの方がエラーなく表示できる桁数(Doubleの範囲まで)は大きいです。

Comments

[KOZ6.0]

Int はそうでしたか。失礼しました。

[jabe]

ご回答とプログラム作成ありがとうございます。
早速プログラムを動作してみました。

以下エラーが発生してしまいました、原因分かりますでしょうか？
実行時エラー9※インデックスが有効範囲にありません。
結果を見てみますと、フォルダ一層目のデータは取得できていました。
2層目の一つのデータを取得し、止まる状況となっております。

よろしくお願いします。

[hatena19]

エラーはどの行で発生しますか。
当方の環境では問題なく動作してます。

[jabe]

連絡ありがとうございます。
そうなんですね。私の環境が問題の可能性があるんですかね？
以下コードでエラーが発生してしまいます。
Dim aryFl(): ReDim aryFl(1 To objFld.Files.Count, 1 To 4)

[hatena19]

フォルダー内のファイル数が０のときにエラーになりますね。
回答のコードを対策したものに修正しましたのでそれを試してみてください。

[jabe]

コード作成ありがとうございました。
問題なく動作しました。
助かりました。
コードの理解進めていきます。

[jabe]

プログラム結果を確認したところ、一部のファイル情報を取得出来ていなかった事が分かりました。
プログラム自体はエラーなく動作しました。
原因分かりますでしょうか？

[hatena19]

「一部のファイル情報を取得出来ていな」いものは何なのか、
どのような条件のときなのか、など、こちらで検証できる情報を提示してもらわないと、
原因特定は難しいです。

[jabe]

ご連絡ありがとうございます。
事象を”追加△1”情報として質問文に追加させていただきました。
ご協力のほどよろしくお願いします。

[jabe]

hatena19さん、上記内容いかがでしょうか？

Answer 3

フォルダのファイル容量を求めるってのは、フォルダの中にあるファイルのファイルサイズをそれぞれ合計していくために時間がかかります。
まあ、そういうもん、とおもっておきましょう

Comments

[Zuishin]

たかだか 200 のファイルでそんなわけないでしょう。

> Set objFs = CreateObject("Scripting.FileSystemObject")

これを毎回やってるのと、処理のたびにセルを一つづついじってるのがパッと見て目につきます。
これらを改善するだけでかなり変わると思いますが。

[jabe]

ご回答ありがとうございます。
セルを１つずつ見ている為、対象フォルダのデータ数が多いと速度に影響しているって事でしょうか。

Set objFs = CreateObject("Scripting.FileSystemObject")
こちら、解消する方法は分かりますでしょうか？