【Excel VBA】サブフォルダ含むファイル一覧を高速に取得

Option Explicit
Private Files_ As Collection
Public Property Get Files() As Collection
    Set Files = Files_
End Property
Public Function getFileList(ByVal SearchType As Integer, ByVal SearchFolder As String, _
                            Optional ByVal SearchFile As String = "*") As cmdFileList
    Dim FSO          As New Scripting.FileSystemObject
    Dim WSH          As New IWshRuntimeLibrary.WshShell
    Dim Command      As String, Result As Variant, i As Long, j As Long
    Dim TempFile     As String: TempFile = ThisWorkbook.Path & "" & FSO.GetTempName
    Dim ParentFolder As String
    Dim FullPath     As String
    Dim SplitFiles   As Variant, SearchFiles As String
    
    On Error GoTo Err_Exit
    
    If InStr(SearchFile, ",") > 0 Then
      SplitFiles = Split(SearchFile, ",")
    Else
      ReDim SplitFiles(0)
      SplitFiles(0) = SearchFile
    End If
    
    For j = 0 To UBound(SplitFiles)
      If Trim(SplitFiles(j)) <> "" Then
        SearchFiles = SearchFiles & Chr(34) & SearchFolder & "" & SplitFiles(j) & Chr(34) & " "
      End If
    Next
    
    If SearchType = 0 Then
      Command = "%ComSpec% /c dir /s /b /A-d-h-s /O:n "
      ParentFolder = ""
    Else
      Command = "%ComSpec% /c dir /b /A-d-h-s /O:n "
      ParentFolder = SearchFolder & ""
    End If
    
    Command = Command & SearchFiles & "> " & Chr(34) & TempFile & Chr(34)
    
    WSH.Run Command, 0, True
    
    With FSO.GetFile(TempFile)
      If .Size = 0 Then
        .Delete
        GoTo Err_Exit
      End If
      
      With .OpenAsTextStream(1, 0)
        Result = Split(.ReadAll, vbCrLf)
        .Close
      End With
      .Delete
    End With
    
    If IsArray(Result) = True Then
    Else
      GoTo Err_Exit
    End If
    
    For i = 0 To UBound(Result)
      If Result(i) <> "" Then
        FullPath = ParentFolder & CStr(Result(i))
        If FSO.FileExists(FullPath) = True Then
          DoEvents
          For j = 0 To UBound(SplitFiles)
            If StrConv(LCase(FullPath), vbNarrow) Like _
               StrConv(LCase(SplitFiles(j)), vbNarrow) Then
              Call Files.Add(FSO.GetFile(FullPath))
              Exit For
            End If
          Next
        End If
      End If
    Next
    
    Erase Result
    Erase SplitFiles
    
Err_Exit:
    Set getFileList = Me
    
    If Err.Number <> 0 Then
      MsgBox "FileListクラスのエラー" & Err.Number, vbCritical, "エラー"
    End If
End Function
Private Sub Class_Initialize()
    Set Files_ = New Collection
End Sub
Private Sub Class_Terminate()
    Set Files_ = Nothing
End Sub

Option Explicit
Sub FileSearch(ByVal PRAM_TYPE As Integer)
  Dim SearchFolder As String
  Dim SearchFile   As String
  Dim Sta_Row      As Long
  Dim Out_Row      As Long
  Dim Result       As Collection
  Dim f            As Scripting.File
  Dim fCnt         As Long: fCnt = 1
  
  If PRAM_TYPE = 0 Or PRAM_TYPE = 1 Then
  Else
    MsgBox "パラメータが誤っています。=> " & PRAM_TYPE, vbCritical, "エラー"
    Exit Sub
  End If
  
  On Error GoTo Err_Exit
  
  With ThisWorkbook.ActiveSheet
    SearchFolder = .Cells(2, 2).Value
    
    If Trim(SearchFolder) = "" Then
      SearchFolder = ThisWorkbook.Path
    End If
    
    SearchFile = .Cells(4, 2).Value 
    
    Sta_Row = 10
    Out_Row = 10
    
    Call DataClear(Sta_Row, .Name)
    
    Application.StatusBar = "処理中です..."
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    Application.Calculation = xlCalculationManual
    Application.EnableCancelKey = xlErrorHandler
    
    With New VBAProject.cmdFileList
      'パラメータは
      '・検索タイプ：0=サブフォルダ含む、1=指定フォルダのみ
      '・検索フォルダ名
      '・検索ファイル名(ワイルドカード可)
      Set Result = .getFileList(PRAM_TYPE, SearchFolder, SearchFile).Files
      
      If Result.Count > 0 Then
      Else
        GoTo Err_Exit
      End If
    End With
    
    For Each f In Result
      DoEvents
      .Cells(Out_Row, 2).Value = f.ParentFolder
      .Cells(Out_Row, 3).Value = f.Name
      .Cells(Out_Row, 4).Value = f.DateLastModified
      .Cells(Out_Row, 4).NumberFormatLocal = "YYYY/MM/DD hh:mm:ss"
      .Cells(Out_Row, 5).Value = Format(Application.WorksheetFunction.RoundUp((f.Size / 1024), 0), "0")
      Application.StatusBar = fCnt & "／" & Result.Count
      Out_Row = Out_Row + 1
      fCnt = fCnt + 1
    Next
    
    If Err.Number <> 0 Then GoTo Err_Exit
    
    Application.Goto reference:=.Cells(Sta_Row, 1), Scroll:=True
    .Cells(Sta_Row, 2).Activate
  End With
  
Err_Exit:
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.Calculation = xlCalculationAutomatic
    Application.EnableCancelKey = xlInterrupt
    
    If Err.Number <> 0 Then
      If Err.Number = 18 Then
        Application.StatusBar = "中断しました。"
      Else
        MsgBox "予期せぬエラー" & Err.Number, vbCritical, "エラー"
      End If
    Else
      MsgBox "処理完了しました。"
    End If
End Sub
Sub DataClear(ByVal wRow As Long, ByVal wSheet As String)
  Application.EnableEvents = False
  
  With ThisWorkbook.Sheets(wSheet)
    .Cells.ClearOutline
    
    If .AutoFilterMode = True Then
      If .AutoFilter.FilterMode = True Then
        .ShowAllData
      End If
    End If
    
    .Range("A" & wRow & ":A" & Rows.Count).EntireRow.Delete
    .Range("A" & wRow & ":A" & Rows.Count).EntireRow.ClearContents
    .Range("A" & wRow & ":A" & Rows.Count).EntireRow.Font.Name = "Meiryo UI"
    .Range("A" & wRow & ":A" & Rows.Count).EntireRow.Font.Size = 10
  End With
  
  Application.EnableEvents = True
End Sub