Excel VBA 逆引き集 | 高速ファイル走査

Excel VBA
スポンサーリンク

ねらい：VBAで「高速ファイル走査」を実現し、数十万件でも固まらず完走する

大量ファイルの走査は、再帰やループの書き方次第で極端に遅くなります。Excelでは「Dirの連続呼び出し＋配列バッファ＋一括書き出し」が最速の基本形です。FileSystemObject（FSO）は書きやすい反面遅い場面があり、純VBAのDirを軸に、進捗の間引き・チャンク出力・フィルタを組み合わせると、数十万件規模でも安定して終わります。初心者向けに貼って動くテンプレートと、実務で効く深掘りを示します。

重要ポイントの深掘り

  • 走査結果は「配列に貯めて一括で書く」。セルへ都度書くと致命的に遅くなります。
  • 再帰はスタックを使うため、極端に深い階層で不利。キュー（スタック）にフォルダを入れて非再帰にする方が安全です。
  • 絞り込み（拡張子・サイズ閾値・更新時刻）を早い段階で行い、無駄な情報をそもそも貯めないことが速度に直結します。

最速の軸：Dirによる非再帰走査＋配列バッファ

非再帰でフォルダをキューに入れて広げる

' ModFastScan_Dir.bas
Option Explicit

Public Sub Run_FastScan_Dir(ByVal root As String, Optional ByVal extsCsv As String = "*", Optional ByVal maxRows As Long = 200000)
    On Error GoTo EH
    AppEnter "FastScan"

    Dim ws As Worksheet
    Set ws = PrepareOutputSheet("Scan")

    Dim allowedExts() As String
    allowedExts = Split(UCase$(extsCsv), ",")

    Dim buf() As Variant: ReDim buf(1 To 5000, 1 To 5) ' チャンク書き出し用バッファ
    Dim w As Long: w = 0
    Dim total As Long: total = 0

    Dim q() As String: ReDim q(1 To 1)
    q(1) = root
    Dim head As Long: head = 1
    Dim tail As Long: tail = 1

    Dim rowOut As Long: rowOut = 2
    ws.Range("A1:E1").Value = Array("Path", "Name", "Ext", "Size(bytes)", "LastWriteTime")

    Do While head <= tail
        Dim folder As String: folder = q(head): head = head + 1

        Dim f As String
        f = Dir(folder & "\*", vbDirectory)
        Do While Len(f) > 0
            If f <> "." And f <> ".." Then
                Dim full As String: full = folder & "\" & f
                If (GetAttr(full) And vbDirectory) = vbDirectory Then
                    tail = tail + 1
                    ReDim Preserve q(1 To tail)
                    q(tail) = full
                Else
                    If PassExtFilter(full, allowedExts) Then
                        w = w + 1
                        buf(w, 1) = full
                        buf(w, 2) = f
                        buf(w, 3) = GetExt(full)
                        buf(w, 4) = FileLen(full)
                        buf(w, 5) = FileDateTime(full)
                        total = total + 1
                        If w = UBound(buf, 1) Then
                            ws.Range("A" & rowOut).Resize(w, 5).Value = buf
                            rowOut = rowOut + w
                            w = 0
                            Application.StatusBar = "Found " & total & " files..."
                            If total >= maxRows Then GoTo Done
                        End If
                    End If
                End If
            End If
            f = Dir
        Loop
    Loop

Done:
    If w > 0 Then
        ws.Range("A" & rowOut).Resize(w, 5).Value = buf
    End If
    ws.Columns.AutoFit
    AppLeave
    MsgBox "走査完了: " & total & " 件", vbInformation
    Exit Sub
EH:
    AppLeave
    MsgBox "失敗: " & Err.Description, vbExclamation
End Sub

Private Function PassExtFilter(ByVal path As String, ByVal allowedExts() As String) As Boolean
    If UBound(allowedExts) = 0 And allowedExts(0) = "*" Then PassExtFilter = True: Exit Function
    Dim e As String: e = UCase$(GetExt(path))
    Dim i As Long
    For i = LBound(allowedExts) To UBound(allowedExts)
        If e = Trim$(allowedExts(i)) Then PassExtFilter = True: Exit Function
    Next
End Function

Private Function GetExt(ByVal path As String) As String
    Dim p As Long: p = InStrRev(path, ".")
    If p > 0 Then GetExt = Mid$(path, p + 1) Else GetExt = ""
End Function

Private Function PrepareOutputSheet(ByVal name As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = name
    End If
    ws.Cells.Clear
    Set PrepareOutputSheet = ws
End Function
VB

重要ポイントの深掘り

  • Dirは「同一スレッド内で状態を持つ」ため、同時に複数Dirループを走らせないようにします。非再帰でフォルダ名をキューへ追加し、1本のDirで広げる設計が速くて安全です。
  • バッファは2,000〜10,000行程度がバランス。行ごとの書き込みは禁物です。
  • サイズ・更新時刻などの情報は標準関数（FileLen, FileDateTime）で高速取得できます。

柔軟性重視：FileSystemObject（FSO）で読みやすく書く

FSOで拡張子・サイズ・時刻を取る（速度より可読性）

' ModScan_FSO.bas
Option Explicit

Public Sub Run_Scan_FSO(ByVal root As String, Optional ByVal minSizeBytes As Double = 0)
    On Error GoTo EH
    AppEnter "FSO Scan"

    Dim ws As Worksheet: Set ws = PrepareOutputSheet("ScanFSO")
    ws.Range("A1:F1").Value = Array("Path", "Name", "Ext", "Size(bytes)", "LastWriteTime", "Parent")

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim buf() As Variant: ReDim buf(1 To 3000, 1 To 6)
    Dim w As Long: w = 0, rowOut As Long: rowOut = 2

    Dim stack As Collection: Set stack = New Collection
    stack.Add fso.GetFolder(root)

    Do While stack.Count > 0
        Dim fol As Object: Set fol = stack(1): stack.Remove 1

        Dim subF As Object
        For Each subF In fol.SubFolders
            stack.Add subF
        Next

        Dim fil As Object
        For Each fil In fol.Files
            If fil.Size >= minSizeBytes Then
                w = w + 1
                buf(w, 1) = fil.Path
                buf(w, 2) = fil.Name
                buf(w, 3) = fso.GetExtensionName(fil.Path)
                buf(w, 4) = fil.Size
                buf(w, 5) = fil.DateLastModified
                buf(w, 6) = fil.ParentFolder.Name
                If w = UBound(buf, 1) Then
                    ws.Range("A" & rowOut).Resize(w, 6).Value = buf
                    rowOut = rowOut + w
                    w = 0
                    Application.StatusBar = "FSO Found..."
                End If
            End If
        Next
    Loop

    If w > 0 Then ws.Range("A" & rowOut).Resize(w, 6).Value = buf
    ws.Columns.AutoFit
    AppLeave
    MsgBox "FSO走査完了", vbInformation
    Exit Sub
EH:
    AppLeave
    MsgBox "失敗: " & Err.Description, vbExclamation
End Sub
VB

重要ポイントの深掘り

  • FSOはオブジェクト生成と列挙が多く、Dirより遅くなりがちですが、拡張情報（親フォルダ名など）が簡単に取れる利点があります。
  • 深いフォルダ構造でも非再帰（コレクションのスタック/キュー）なら安全です。
  • サイズフィルタなど「入口で早く捨てる」設計にすると、総処理量が減り体感速度が上がります。

フィルタと並べ替え：走査中に軽く、書き出し後に重く

走査中は最小限の判定だけに絞る

  • 拡張子一致、サイズ閾値、更新時刻（After/Before）の3点に留める。複雑な正規表現や文字列操作は後工程（シート上の関数やPower Query）に回す方が速いです。

書き出し後の並べ替え・重フィルタはExcel機能で

  • 走査結果を書き出したら、テーブル化（Ctrl+T）して列名でフィルタ・並べ替え。開発不要で高速です。
  • 必要なら列関数（LEFT/RIGHT/SEARCH）で軽整形し、ピボットで集約すれば「何が多いか」がすぐ見えます。

超大規模向け：チャンク書き出し＋疑似並列でUIを固めない

OnTimeで段階的に回すテンプレ

' ModScan_Chunked.bas
Option Explicit
Private gQueue() As String, gHead As Long, gTail As Long
Private gBuf() As Variant, gW As Long, gWs As Worksheet, gRowOut As Long, gStop As Boolean

Public Sub StartScanChunked(ByVal root As String)
    gStop = False
    Set gWs = PrepareOutputSheet("ScanChunk")
    gWs.Range("A1:E1").Value = Array("Path", "Name", "Ext", "Size(bytes)", "LastWriteTime")
    gRowOut = 2
    ReDim gBuf(1 To 5000, 1 To 5): gW = 0
    ReDim gQueue(1 To 1): gQueue(1) = root: gHead = 1: gTail = 1
    Application.OnTime Now, "'" & ThisWorkbook.Name & "'!TickScanChunked", , True
End Sub

Public Sub StopScanChunked(): gStop = True: Application.StatusBar = False: End Sub

Public Sub TickScanChunked()
    If gStop Then Exit Sub
    Dim startTick As Double: startTick = Timer
    Do While gHead <= gTail
        Dim folder As String: folder = gQueue(gHead): gHead = gHead + 1
        Dim f As String: f = Dir(folder & "\*", vbDirectory)
        Do While Len(f) > 0
            If f <> "." And f <> ".." Then
                Dim full As String: full = folder & "\" & f
                If (GetAttr(full) And vbDirectory) = vbDirectory Then
                    gTail = gTail + 1: ReDim Preserve gQueue(1 To gTail)
                    gQueue(gTail) = full
                Else
                    gW = gW + 1
                    gBuf(gW, 1) = full
                    gBuf(gW, 2) = f
                    gBuf(gW, 3) = GetExt(full)
                    gBuf(gW, 4) = FileLen(full)
                    gBuf(gW, 5) = FileDateTime(full)
                    If gW = UBound(gBuf, 1) Then
                        gWs.Range("A" & gRowOut).Resize(gW, 5).Value = gBuf
                        gRowOut = gRowOut + gW: gW = 0
                        Application.StatusBar = "Chunk write..."
                    End If
                End If
            End If
            f = Dir
        Loop
        If Timer - startTick > 0.2 Then Exit Do ' 約200msで区切る
    Loop

    If gHead > gTail Then
        If gW > 0 Then gWs.Range("A" & gRowOut).Resize(gW, 5).Value = gBuf
        Application.StatusBar = "完了"
    Else
        Application.OnTime Now + 0.5 / 86400#, "'" & ThisWorkbook.Name & "'!TickScanChunked", , True
    End If
End Sub
VB

重要ポイントの深掘り

  • 「200msで区切って再予約」はUI応答を保ちながら進める定番。大量フォルダでも固まりません。
  • バッファ書き出しでディスクI/Oをまとめ、行ごと書くコストを消します。
  • キャンセル（Stop）で次チャンク開始前に抜けるようにして、いつでも安全に止められるようにします。

補助ツール連携：PowerShellで一覧生成→VBAで読み込み

外部で高速一覧、VBAでは表示と加工に専念する

  • PowerShell例（Get-ChildItemで再帰、CSV出力）
Get-ChildItem -Path "C:\Data" -Recurse -File |
 Select-Object FullName, Name, Extension, Length, LastWriteTime |
 Export-Csv -Path "C:\Data\list.csv" -NoTypeInformation -Encoding UTF8
  • VBAでCSV読み込み（UTF-8）
' ModCsvLoad.bas
Option Explicit
Public Function LoadCsvToArray(ByVal path As String) As Variant
    Dim st As Object: Set st = CreateObject("ADODB.Stream")
    st.Type = 2: st.Charset = "UTF-8": st.Open: st.LoadFromFile path
    Dim text As String: text = st.ReadText: st.Close
    Dim lines() As String: lines = Split(text, vbCrLf)
    Dim head() As String: head = Split(lines(0), ",")
    Dim rows As Long: rows = UBound(lines)
    Dim cols As Long: cols = UBound(head) + 1
    Dim a() As Variant: ReDim a(1 To rows, 1 To cols)
    Dim r As Long, c As Long
    For c = 1 To cols: a(1, c) = head(c - 1): Next
    For r = 2 To rows
        If Len(lines(r - 1)) = 0 Then Exit For
        Dim rec() As String: rec = Split(lines(r - 1), ",")
        For c = 1 To cols: a(r, c) = IIf(c - 1 <= UBound(rec), rec(c - 1), ""): Next
    Next
    LoadCsvToArray = a
End Function

Public Sub ShowCsv(ByVal path As String)
    Dim ws As Worksheet: Set ws = PrepareOutputSheet("ScanCsv")
    Dim a As Variant: a = LoadCsvToArray(path)
    ws.Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
    ws.Columns.AutoFit
End Sub
VB

重要ポイントの深掘り

  • 外部に任せると「一覧生成のスピード」はさらに出ます。VBAは表示・フィルタ・集計に専念すると、全体の設計がシンプルで壊れにくくなります。
  • CSVはUTF-8で固定。Excel側で文字化けしないように、Streamの文字コードを揃えます。

共通枠：必ず復帰し、UIを固めない基本テンプレ

開始・終了枠

' ModApp.bas
Option Explicit
Public Sub AppEnter(Optional ByVal status As String = "")
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    If Len(status) > 0 Then Application.StatusBar = status
End Sub
Public Sub AppLeave()
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB

重要ポイントの深掘り

  • 走査は時間がかかります。描画・イベントを止めて速度を確保し、終了時は必ず元に戻す。
  • StatusBarは進捗や件数の可視化に有効ですが、毎行更新は禁物。チャンク終端だけ更新します。

例題の通し方と検証ポイント

手順

  • Run_FastScan_Dir “C:\Data”, “CSV,TXT,XLSX” を実行して、拡張子フィルタが効いた一覧が出るか確認します。
  • Run_Scan_FSO “C:\Data”, 100000 でサイズ100KB以上に絞って動作を比較します。
  • StartScanChunked “C:\Data” でUIが固まらず進行するか、StopScanChunked で安全に止まるかを確認します。
  • ShowCsv “C:\Data\list.csv” で外部生成CSVの読込が正しく表示されるか確認します。

確認ポイント

  • 書き出しはチャンク単位で行われているか（行単位でなく）。
  • 大量階層でもエラーなく完了するか。権限のないフォルダでDir/GetAttrが失敗する場合はOn Errorの局所ガードを追加。
  • 進捗更新が間引かれており、体感が滑らかか。

まとめ：Dir＋非再帰＋配列バッファが「速さの核」。必要に応じてFSOや外部連携を併用する

  • 最速はDirで非再帰走査、結果は配列バッファへ貯めて一括書き込み。
  • 可読性・拡張情報が欲しければFSOで、ただしバッファとチャンク出力は維持。
  • 超大規模はOnTimeでチャンク化し、UI応答と完走性を両立。
  • さらに大規模・厳密要件はPowerShellで一覧生成→VBAで表示に分担。

スポンサーリンク
タイトルとURLをコピーしました