エクセルでファイルリストの作成VBAをもっと高速にする方法を教えてください。

Question

Sub FolderScript()

Dim strPath As String, i As Long

strPath = Range("B2").Value

Range("B3").Select
i = 3
Fileshow strPath, i

End Sub

Public Sub Fileshow(strPath, i)
Dim objFso As Object, objFolder As Object, objFile As Object
Dim objSub As Object, ws As Worksheet
Dim strList() As String

Dim rr As Range
Dim bb
Dim y As Integer
Dim col As Integer

Dim oFile As Object

Set ws = ThisWorkbook.Worksheets("FileList")
Set objFso = CreateObject("scripting.Filesystemobject")
Set objFolder = objFso.GetFolder(strPath)

Application.ScreenUpdating = False

For Each objFile In objFolder.Files
ws.Cells(i, 2) = objFso.GetBaseName(objFile.Path)
ws.Cells(i, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Name

ws.Cells(i, 3) = objFile.Type
ws.Cells(i, 4) = Int(objFile.Size / 1024)
ws.Cells(i, 5) = objFile.DateCreated
ws.Cells(i, 6) = objFile.DatelastAccessed
ws.Cells(i, 7) = objFile.DateLastModified
ws.Cells(i, 8) = objFile.ParentFolder.Path

For Each rr In ws.Cells(i, 8).Rows
bb = Split(rr, "\")
col = 9
For y = 1 To UBound(bb)
Cells(rr.Row, col) = bb(y)
col = col + 1
Next y

i = i + 1
Next rr

Next

For Each objSub In objFolder.SubFolders
Fileshow objSub.Path, i
Next

End Sub
コード
```Excel VBAを使ってファイルリスト作成をおこなっています。
現在の課題は、５万ファイルに及ぶ大規模なリスト作成のためにこのマクロコードを使うと
リスト作成の完了までおよそ４時間くらいかかってしまうため、この所要時間を２時間くらいまで短縮化したいと思っています。

要望
ファイルリストの作成VBAをもっと高速にする方法を教えてください。
よろしくアドバイスをお願いいたします。

Sub FolderScript()

Dim strPath As String, i As Long

strPath = Range("B2").Value

Range("B3").Select
i = 3
Fileshow strPath, i

End Sub

Public Sub Fileshow(strPath, i)
Dim objFso As Object, objFolder As Object, objFile As Object
Dim objSub As Object, ws As Worksheet
Dim strList() As String

Dim rr As Range
Dim bb
Dim y As Integer
Dim col As Integer

Dim oFile As Object

Set ws = ThisWorkbook.Worksheets("FileList")
Set objFso = CreateObject("scripting.Filesystemobject")
Set objFolder = objFso.GetFolder(strPath)

Application.ScreenUpdating = False

    For Each objFile In objFolder.Files
        ws.Cells(i, 2) = objFso.GetBaseName(objFile.Path)
        ws.Cells(i, 2).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Name
        
        ws.Cells(i, 3) = objFile.Type
        ws.Cells(i, 4) = Int(objFile.Size / 1024)
        ws.Cells(i, 5) = objFile.DateCreated
        ws.Cells(i, 6) = objFile.DatelastAccessed
        ws.Cells(i, 7) = objFile.DateLastModified
        ws.Cells(i, 8) = objFile.ParentFolder.Path
              
            For Each rr In ws.Cells(i, 8).Rows
               bb = Split(rr, "\")
               col = 9
               For y = 1 To UBound(bb)
                   Cells(rr.Row, col) = bb(y)
                   col = col + 1
               Next y
        
        i = i + 1
               Next rr
               
    Next
    
    For Each objSub In objFolder.SubFolders
        Fileshow objSub.Path, i
    Next

End Sub

Comments

[hatena19]

コードはマークダウンのコードブロックに入れてください。

```vba
ここにコードを記述
```

[ELBE]

セル書き込みとセル選択がループ1回毎に約10回行われています。
描画をオフにしているとはいえ、5万回×10回のセル書き込みとセル選択が行われていることが遅い原因です。

仮に1回のセル書き込みが20msであったとしても、50万回も行われれば3時間はかかりますね。

[KANNORYUJI]

ご指摘ありがとうございます。そのとうりです
例えば全ての情報を取得後にセル書き込みを１回だけで済ますコードの案があればもっと早くなるかと思うのですが、もし方策がありましたら是非アドバイス願います。

[hihijiji]

一度CSVに書き込んで、そのCSVをExcelにインポートするのは如何でしょう？

Answer 1

自分が作ったExcelアドインで実行した結果

ローカルHDDで
180,000ファイルで約90秒でした
(PCスペックはそれほど良いものではありません。)

工夫点は

• ファイル情報はAPIをメインに使用

ちょっと言葉が足りなかったですね。最近は「API」と書くと「Web API」と思われてしますのですが
ここでは「Windows API」事です。
質問者様が今回使われた"scripting.Filesystemobject"のさらに下の階層にある命令で行うので
余計な処理が含まれない為処理を早くすることが出来ます。
(これは他の回答者様がすでに指摘されている内容です)

• クラス化

これは単純にデータの持ち方の為に用意しました。(階層構造の保存の為)

• 再帰呼び出しを使用

自関数をさらに内部でパラメータを変えて自関数を呼び出す方法です。
今回はフォルダが階層になっているので判りやすいかと思います。

• ファイル情報はまとめて最後に出力

(これも他の回答者様が最後一括でvalueに設定すればよいと、すでに指摘されている内容です)

でしょうか？

Comments

[KANNORYUJI]

180,000ファイルで約90秒は超早いです！
詳しく教えてください

[KANNORYUJI]

ファイル情報はAPIをメインに使用
から理解できておりません
ご教授をお願いいたします

[kuma_kuma_]

すみませんいま別の回答準備中なので返答までお時間いただければ
もう少しは追記できます。

[KANNORYUJI]

わかりやすい補足説明をいただきありがとうございました。

Answer 2

ファイルリストの作成VBAをもっと高速にする方法を教えてください。

1）セルをSelectしない。
Selectしなくても命令は書けるので、Selectしないような書き方を覚えてください。Selectすることで画面の表示を変えるとか、無駄なことが行われるので、時間がかかります。やめましょう。

2）個別のセルの読み書きをすることをやめる
個別のセルを読み書きすることも時間がかかります。
まとめてセル範囲でできることはまとめてセル範囲で実行しましょう。
つまり値の加工は変数上でやりきってから、シート上に書き込みます。

3）FSOは割と遅い
VBAでファイルの一覧を取得する方法はいくつかあります。
FSO＞Dir関数＞Dirコマンド　の順で速かった気がします。
ただし、FSOの利便性も捨てがたいので適材適所で道具を使い分けましょう。

Option Explicit

Sub test()
    Dim v
    Dim t
    
    t = Timer
    
    v = GetFileList("D:\現場")  'ファイルの一覧を一次元配列で取得
    v = GetFilesInfo(v)         'ファイルの情報を付加して二次元配列に展開
    
    With ActiveSheet.Range("C3").Resize(UBound(v, 1), UBound(v, 2))
        .Value = v                                  '変数の値をシート上に書き込み
        .Columns(0).Formula = "=HYPERLINK(C3,D3)"   '数式でハイパーリンクを設定
    End With
    
    MsgBox Timer - t
End Sub

Function GetFileList(ByVal SEARCH_DIR As String) As Variant
    Dim tmpFile As String
    Dim strCmd As String
    Dim buf() As Byte
    Dim FileList() As String
        
    'Dirコマンドの結果を出力する一時ファイル
    tmpFile = Environ("TEMP") & "\Dir.tmp"
    
    'Dirコマンド用の文字列を編集
    strCmd = "Dir """ & SEARCH_DIR & """ /b/s/a:-d-h-s > """ & tmpFile & """"
    
    'WSHでDirコマンドを実行
    With CreateObject("Wscript.Shell")
        .Run "cmd /c" & strCmd, 7, True
    End With
    
    '該当ファイルの存在チェック
    If FileLen(tmpFile) < 1 Then
        MsgBox "該当するファイルがありません"
        Exit Function
    End If
    
    'Dirコマンドの結果を出力した一時ファイルを読み込み
    Open tmpFile For Binary As #1
    ReDim buf(1 To LOF(1))
    Get #1, , buf
    Close #1
    Kill tmpFile
    
    GetFileList = Split(StrConv(buf, vbUnicode), vbCrLf)
End Function

Function GetFilesInfo(ByVal vrtList As Variant) As Variant
    Dim FSO As New FileSystemObject
    Dim f As File
    Dim i As Long
    Dim v() As Variant
    ReDim v(1 To UBound(vrtList) + 1, 1 To 7)
    
    For i = LBound(v, 1) To UBound(v, 1)
        Set f = Nothing
        On Error Resume Next
        Set f = FSO.GetFile(vrtList(i - 1))
        On Error GoTo 0
        
        If Not f Is Nothing Then
            v(i, 1) = f.Path
            v(i, 2) = FSO.GetBaseName(f)
            v(i, 3) = f.Type
            v(i, 4) = f.Size
            v(i, 5) = f.DateLastAccessed
            v(i, 6) = f.DateLastModified
            v(i, 7) = f.ParentFolder.Path
        End If
    Next
    
    GetFilesInfo = v
End Function

ハイパーリンクも個別に設定すると、5万回、セルに設定しないといけないので、一括でできる数式でやってみました。（数式は一括で設定できる）
それを、一括で普通のハイパーリンクにもできそうですが手順が面倒なので、
今回は数式を入力するまでとしてます。
興味があればネットで調べてみてください。
つまり、今回のマクロは、
一括で数式を入力するために色々やっています。

2800個のファイルで
5秒弱だったので数分でできると思います。
Dirコマンドの使い方をよくわかってないので、
リストが上手く作れてないかもです。
動作確認を十分にし、自己責任でお使いください。

Comments

[KANNORYUJI]

ありがとうございます早速試しにやってみます

Answer 3

シート（FileList）の中にもし、関数式が埋め込まれているなら、以下の対策が有効になります。
Sub FolderScript()のFileshow strPath, iの前で、
自動再計算、画面表示をOFFします。
そのあとで、自動再計算、画面表示をもとに戻します。
尚、そのようにした場合、
Public Sub Fileshow(strPath, i)内の
Application.ScreenUpdating = False
は不要ですので削除してください。

Sub FolderScript()

    Dim strPath As String, i As Long
    strPath = Range("B2").Value

    Range("B3").Select
    i = 3
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Fileshow strPath, i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

Comments

[KANNORYUJI]

大変勉強になります。
データ取り込みの効率化につながります
ありがとうございます

Answer 4

とりあえず無駄なSelect、無駄な代入は削除。

ws.Cells(i, 2) = objFso.GetBaseName(objFile.Path)
ws.Cells(i, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Name

これは下記の1行でOK。

ActiveSheet.Hyperlinks.Add Anchor:=ws.Cells(i, 2), Address:=objFile.Path, TextToDisplay:=objFile.Name

これで若干は改善されるかも。半分はたぶん無理。

セル一つずつに代入するのではなく取得したファイルデータを配列にいれて、できる限りまとめて代入すると改善するでしょう。

ws.Cells(i, 3) = objFile.Type
ws.Cells(i, 4) = Int(objFile.Size / 1024)
ws.Cells(i, 5) = objFile.DateCreated
ws.Cells(i, 6) = objFile.DatelastAccessed
ws.Cells(i, 7) = objFile.DateLastModified
ws.Cells(i, 8) = objFile.ParentFolder.Path

の部分は、下記にすると、6回の代入が1回ですみます。

ws.Cells(i, 3).Resize(, 6).Value = _
    Array(objFile.Type, Int(objFile.Size / 1024), objFile.DateCreated, _
          objFile.DatelastAccessed, objFile.DateLastModified, objFile.ParentFolder.Path)

さらに、改善させるには、
全ての行のデータを配列にいれて一気に代入するとさらに高速化できますが、
ハイパーリンクとかは無理なので、ハイパーリンクは後から設定するとかの工夫は必要になります。

---

全ての行のデータを配列にいれて一気に代入する方法をぼちぼち書いていたら、既に他の方から回答がいろいろついてしまいましたね。

配列は10万行固定の無理やりのものです(;^_^A
行方向は増やせないし、縦横変換も面倒なので、、、
フォルダー単位で書き出してますので、1フォルダー内のファイルが10万を超えるとエラーになります。
手抜きです。

Sub FolderScript1()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim StartRow As Long, ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("FileList")
    StartRow = 3
    
    Fileshow1 ws.Range("B2").Value, ws, StartRow
    
    With ThisWorkbook.Worksheets("FileList").Range("B3:B" & StartRow)
        .Formula = .Value
    End With
        
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Public Sub Fileshow1(ByVal strPath As String, ws As Worksheet, ByRef StartRow As Long)

    Dim objSub As Object
    Dim strList() As String

    Dim rr As Range
    Dim bb
    Dim y As Integer
    Dim col As Integer

    Dim objFso As Object, objFolder As Object
    Set objFso = CreateObject("scripting.Filesystemobject")
    Set objFolder = objFso.GetFolder(strPath)


    Dim FileDatas() As String
    ReDim FileDatas(1 To 10000, 1 To 8) As String

    Dim i As Long
    i = 0

    Dim objFile As Object
    For Each objFile In objFolder.Files
        i = i + 1
        FileDatas(i, 1) = "=HYPERLINK(""" & objFile.Path & """,""" & objFile.Name & """)"
        FileDatas(i, 2) = objFile.Type
        FileDatas(i, 3) = Int(objFile.Size / 1024)
        FileDatas(i, 4) = objFile.DateCreated
        FileDatas(i, 5) = objFile.DatelastAccessed
        FileDatas(i, 6) = objFile.DateLastModified
        FileDatas(i, 7) = objFile.ParentFolder.Path
        
        Dim aSubFolders, aSubFolder
        aSubFolders = Split(FileDatas(i, 7), "\")
        If UBound(aSubFolders) > UBound(FileDatas, 2) - 7 Then
            ReDim Preserve FileDatas(1 To 10000, 1 To UBound(aSubFolders) + 7)
        End If

        Dim c As Long
        For c = 1 To UBound(aSubFolders)
            FileDatas(i, c + 7) = aSubFolders(c)
        Next
    Next


    If i > 0 Then ws.Cells(StartRow, 2).Resize(i, UBound(FileDatas, 2)).Value = FileDatas

    StartRow = StartRow + i

    For Each objSub In objFolder.SubFolders
        Fileshow1 objSub.Path, ws, StartRow
    Next

End Sub

Answer 5

こんな感じでどうでしょう？
・何はともあれ配列化
・配列でハイパーリンクを扱うため、HYPERLINK関数を利用
・2次元配列は2次元目しか拡張できないので、1次元目を大きくとる（ただの力技）
・Functionの最後におまじないとしてDoEvents入れてますが、フォルダーの数が多いとDoEventsの回数も増えるので、処理が遅くなります

わたしの環境ですが、所要時間は100000行（到達した時点で強制的にExit）で一時間程度でした。

Sub FolderScript()

Dim strPath As String, i As Long
Dim filelist() As String
    strPath = Range("B2").Value

    Range("B3").Select
    i = 0

    outlist = Fileshow(strPath, i, filelist, start)

ReDim output(UBound(outlist, 2), 50)

'配列を縦横入れ替え
    For n = 0 To UBound(outlist, 1)
        For i = 0 To UBound(outlist, 2)
            output(i, n) = outlist(n, i)
        Next
    Next

    With ThisWorkbook.Worksheets("FileList")
        .Range(.Cells(3, 2), .Cells(3 + i, 2 + n)) = output
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = True
    End With

End Sub

Public Function Fileshow(strPath, i, filelist() As String)
Dim objFso As Object, objFolder As Object, objFile As Object
Dim objSub As Object, ws As Worksheet
Dim strList() As String

Dim rr As Range
Dim bb
Dim y As Integer
Dim col As Integer

Dim oFile As Object

Set ws = ThisWorkbook.Worksheets("FileList")
Set objFso = CreateObject("scripting.Filesystemobject")
Set objFolder = objFso.GetFolder(strPath)

With Application
    .ScreenUpdating = False
    .Calculation = False
End With
For Each objFile In objFolder.Files

    ReDim Preserve filelist(50, i) 'お好みの大きさ
    　　　　　　　　　　　　　　　　　
    'Application.StatusBar = i

'配列に格納するため、HYPERLINK関数で入力    
    filelist(0, i) = "=HYPERLINK(""" & objFile.Path & """,""" & objFso.GetBaseName(objFile.Path) & """)"
    
    filelist(1, i) = objFile.Type
    filelist(2, i) = Int(objFile.Size / 1024)
    filelist(3, i) = objFile.DateCreated
    filelist(4, i) = objFile.DatelastAccessed
    filelist(5, i) = objFile.DateLastModified
    filelist(6, i) = objFile.ParentFolder.Path
    

’For Eachの理由がわからなかったので削除。必要なら復活させてください。
        bb = Split(filelist(6, i), "\")
        
        col = 7
        For y = 1 To UBound(bb)
            filelist(col, i) = bb(y)
            col = col + 1
        Next y
        
        i = i + 1
   
Next

For Each objSub In objFolder.SubFolders
    Fileshow　objSub.Path, i, filelist
Next

DoEvents
Fileshow = filelist
End Function

Comments

[KANNORYUJI]

アドバイスをありがとうございます　早速試してみましたが
Fileshowでどういう訳か
”引数がありません　または不正なパラメータです”
と返ってきて止まってしまいました。
原因を調査中です

[Usirow]

あ、すみません。最初にFileShowを呼び出す
outlist = Fileshow(strPath, i, filelist, start)
を
outlist = Fileshow(strPath, i, filelist)
に変えてください。時間測るために入れておいた変数の削除を忘れていました……