VBA

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

2019-10-14

Excel上でFileSystemObject(vba)とDirコマンドを使用して再帰的にフォルダを高速検索し、ファイル一覧を作成する方法です。クラスモジュールを追加して対応します。

 

検索は高速化のためDirコマンドを使用しますが、拡張子が3桁指定の場合If文で補助する必要があります。

 

表示する時は、fileオブジェクトのプロパティを使用する方がスマートですので、そちらを使用していきます。

・FileSystemObjectは高機能だが再起処理をするには遅い。

・Dirコマンドは速いが拡張子が3桁指定だと.xls,.xlsx等の区別ができない。

・セキュリティ上、フリーソフトは入れられない。もしくは入れたくない。

ということを踏まえた記事となっています。

 

また、記事の下部では既に作成済みのサンプルプログラムをダウンロードできます。

 
 

ソースコード

マクロブックのフォルダ配下にあるファイル(サブフォルダ含む)を一覧にします。もちろん、任意のフォルダやファイル名を指定することも可能です。

 

メモ

※ファイル名は大文字小文字を区別しないように設定しました。区別する場合は、StrConv(LCase( ), vbNarrow)の部分を消去してください。パラメータから指定できるように設定しても良いかもしれませんね。

※サブフォルダを除外する場合は、Dirコマンドの/sオプションをはずすことになりますが、Dirコマンドが返す結果がフルパスではなくファイル名となるため、検索フォルダを連結しています。(Fileをコレクションする際にフルパスが必要なため)

 

※2019/10/20追記 複数ファイル名へ対応。検索ファイル名へカンマ(,)区切りで指定。

クラスモジュール:cmdFileList.cls
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
標準モジュール:FileSearch.bas
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
 
sample_Recursive_FileList

サンプル画面

 
ボタン パラメータ
検索ボタン 'FileSearch 1'
検索(サブフォルダ含む)ボタン 'FileSearch 0'

※フォルダーを選択する部分はこちらの記事を参考にしてみて下さい。

関連記事フォルダーを選択するダイアログを開く【Excel VBA】

 

参照設定

使用する場合は、以下参照設定が必要です。 不要な方はCreateObjectで対応ください。

(開発タブ⇒Visual Basic⇒ツール(T)⇒参照設定)

Microsoft Scripting Runtime Scripting.FileSystemObject
Scripting.File
Windows Script Host Object Model IWshRuntimeLibrary.WshShell
 
VBA参照設定

参照設定

 

検証環境

Microsoft Office Excel 2010 および 2016で検証しています。

 

サンプルプログラムをダウンロード

プログラムの配布は停止いたしました。(2021/2/6)

今までご利用ありがとうございました。

-VBA
-

© 2021 ReiCodeBlog