https://www.limecode.jp/entry/fungo/066-search-files-in-all-subfolders

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：全サブフォルダからファイルを探す

#VBA100本ノック 66本目
ブック自身のあるフォルダ以下の全サブフォルダを検索し、自身と同一名称（拡張子含めて）のファイルを探してください。
同一名称のファイルが見つかったら、シートに出力してください。
・A列：フルパス
・B列：更新日時
・C列：ファイルサイズ
※シートは任意

実行結果サンプル

◇ 出題ページはこちら

ソースコード

定義モジュール

' 同名リスト
Public Const R1st同名リスト = 2
Public Const C1st同名リスト = 1
Public Enum CNo同名リスト
    フルパス = C1st同名リスト
    更新日時
    サイズ
End Enum
Public Const CLast同名リスト = CNo同名リスト.サイズ

メインモジュール

Option Explicit

' 100本ノック066：全サブフォルダからファイルを探す
Sub 自身と同名のファイルを全サブフォルダから検索する()
    
    Call 指定行より下をすべて削除する(WS同名リスト, R1st同名リスト)

    ' 同名のファイルを検索してコレクションに格納
    Dim Clct同名ファイル As New Collection
    Set Clct同名ファイル = GetCollectionフォルダ内ファイルリスト(ThisWorkbook.Path _
        , FSO.GetBaseName(ThisWorkbook.Name) _
        , FSO.GetExtensionName(ThisWorkbook.Name) _
        , is下層フォルダまで取得:=True)
        
    If Clct同名ファイル.Count = 1 Then ' ※ 自身もカウントされるため0ではなく1
        MsgBox "同名ファイルはありませんでした。"
        Exit Sub
    End If
        
    ' 自身以外のファイルをシートに書き出し
    Dim R As Long: R = R1st同名リスト
    Dim 同名ファイル As File
    For Each 同名ファイル In Clct同名ファイル
        If 同名ファイル.Path <> ThisWorkbook.FullName Then
        
            WS同名リスト.Cells(R, CNo同名リスト.フルパス) = 同名ファイル.Path
            WS同名リスト.Cells(R, CNo同名リスト.更新日時) = 同名ファイル.DateLastModified
            WS同名リスト.Cells(R, CNo同名リスト.サイズ) = 同名ファイル.Size
            R = R + 1
            
        End If
    Next
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' フォルダ内のファイルリストの取得
' 参考：https://www.limecode.jp/entry/utility/get-file-list-function-in-folder
Function GetCollectionフォルダ内ファイルリスト(Path対象フォルダ As String _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional is下層フォルダまで取得 As Boolean = False) As Collection
    
    ' ファイルが存在しなくても空のコレクションは返す(Nothingは返さない)
    Set GetCollectionフォルダ内ファイルリスト = New Collection
    
    ' 返り値用コレクション
    Dim Clct対象ファイル As New Collection
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path対象フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path対象フォルダ)

    ' 指定フォルダ内のすべてのファイルを走査
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        
        ' 条件を満たすファイルの情報をCollectionに格納
        If ファイル.Name Like ファイルLike条件 & "." & 対象拡張子 Then
            Clct対象ファイル.Add ファイル
        End If

    Next ' 指定フォルダ内のすべてのファイルを走査
    
    ' 下層フォルダも取得する場合の再帰処理
    If is下層フォルダまで取得 Then
        
        Dim 子フォルダ As Folder
        For Each 子フォルダ In 対象フォルダ.SubFolders
            
            ' 子フォルダへ本関数を再帰呼出してCollectionを取得
            Dim Clct子フォルダ対象ファイル As Collection
            Set Clct子フォルダ対象ファイル = GetCollectionフォルダ内ファイルリスト _
                (子フォルダ.Path, ファイルLike条件, 対象拡張子, True)
            
            ' 子フォルダのCollectionを本関数のCollectionと結合
            For Each ファイル In Clct子フォルダ対象ファイル
                Clct対象ファイル.Add ファイル
            Next
    
        Next ' 指定フォルダ内のすべてのファイルを走査
        
    End If
    
    ' 最終結果を返す
    Set GetCollectionフォルダ内ファイルリスト = Clct対象ファイル
End Function

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub