【Excel VBA】サブフォルダを含むファイル一覧を書き出す

' ****************************************
' 概要　：ファイル一覧の書き出しを行う
' 引数　：なし
' 戻り値：なし
' ****************************************
Public Sub writeFileList()
    Dim fso As New FileSystemObject ' FileSystemObject
    Dim targetFolder As Folder      ' 検索対象Folderオブジェクト
    Dim targetFolderPath As String  ' 検索対象フォルダパス
    Dim startRowIndex As Long       ' 書き出し開始行Index

    ' 検索対象フォルダパスを入力させる
    targetFolderPath = "C:\Users\xxxx\AppData\Local\Microsoft\Office\16.0"

    ' 書き出し開始の行を設定
    startRowIndex = 2

    ' フォルダが存在した場合のみ処理を実行
    If fso.FolderExists(targetFolderPath) Then

        ' 検索対象のフォルダオブジェクトを生成する
        Set targetFolder = fso.GetFolder(targetFolderPath)
    
        ' ファイルの検索と書き出しを行う
        Call execFileSearch(fso, targetFolder, startRowIndex)
    End If

    ' オブジェクトの解放
    Set fso = Nothing
    Set targetFolder = Nothing
End Sub

' ****************************************
' 概要　：ファイルの検索を行う（サブフォルダーを含む）
' 引数　：fso             … FileSystemObject
'         folderObj       … 検索対象Folderオブジェクト
'         currentRowIndex … 書き出し行Index
' 戻り値：なし
' ****************************************
Private Sub execFileSearch( _
    ByVal fso As FileSystemObject, ByVal folderObj As Folder, ByRef currentRowIndex As Long)
    Dim fileObj As File         ' Fileオブジェクト
    Dim subFolderObj As Folder  ' サブフォルダ用 Folderオブジェクト

    ' 検索対象フォルダ配下のファイルをループする
    For Each fileObj In folderObj.Files

        ' ファイル情報を書き出し
        Call writeFileInfo(fso, fileObj, currentRowIndex)
    Next fileObj

    ' サブフォルダ情報を書き出し
    For Each subFolderObj In folderObj.SubFolders

        ' サブフォルダを対象とし、再度ファイルの検索を行う
        Call execFileSearch(fso, subFolderObj, currentRowIndex)
    Next subFolderObj

    ' オブジェクトの解放
    Set fileObj = Nothing
    Set subFolderObj = Nothing
End Sub

' ****************************************
' 概要　：ファイル情報の書き出し
' 引数　：fso             … FileSystemObject
'         folderObj       … Fileオブジェクト
'         currentRowIndex … 書き出し行Index
' 戻り値：なし
' ****************************************
Private Sub writeFileInfo(ByVal fso As FileSystemObject, ByVal fileObj As File, ByRef currentRowIndex As Long)

    ' マクロを実行しているブックの1番目のシートに書き出し
    With ThisWorkbook.Worksheets(1)

        ' フォルダ情報の書き出し
        .Cells(currentRowIndex, 1).Value = fileObj.ParentFolder.Path  ' フォルダパス
        .Cells(currentRowIndex, 2).Value = fileObj.ParentFolder.Name  ' フォルダ名
    
        ' ファイル情報の書き出し
        .Cells(currentRowIndex, 3).Value = fileObj.Name                       ' ファイル名
        .Cells(currentRowIndex, 4).Value = fso.GetExtensionName(fileObj.Name) ' 拡張子
        .Cells(currentRowIndex, 5).Value = fileObj.Size                       ' ファイルサイズ(Byte)
    End With

    ' 書き出し行Indexをインクリメント
    currentRowIndex = currentRowIndex + 1
End Sub