トップ　>　汎用コード　>　ファイルのリストアップ

'-----------------------------------------------------------------------
' 指定したフォルダ配下のサブフォルダとファイルをリストアップするマクロ
'-----------------------------------------------------------------------
'［作成日］2013.06.18　［更新日］2023.11.19
' https://excel.syogyoumujou.com/vba/file_listup.html
'-----------------------------------------------------------------------
Sub MacroToListFiles()
    '対象フォルダの選択
    Dim strFolderPath As String 'フォルダパス格納用
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub            'フォルダ参照が「キャンセル」なら終了
        End If
    End With
    If Dir(strFolderPath, vbDirectory) = "" Then GoTo ERROR1
        
    Application.ScreenUpdating = False
    
    '新規ブックを追加しシートをオブジェクト変数にセット
    Dim Sh As Worksheet
    Set Sh = Workbooks.Add.Worksheets(1)
    
    '新規ブックのセルA1に選択したフォルダ名を書き込み
    Sh.Cells(1, 1).Value = "[" & strFolderPath & "]"
    
    'サブフォルダ・ファイルのリストアップ
    If Not ListSubfoldersAndFiles(Sh, 2, 2, strFolderPath) Then GoTo ERROR2
    
    Application.ScreenUpdating = True
    
    MsgBox "リストアップ終了", vbOKOnly + vbInformation
    Exit Sub
ERROR1:
    MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します"
    Exit Sub
ERROR2:
    MsgBox "予期せぬエラーが発生しました", vbOKOnly + vbExclamation, "中止します"
End Sub

'-----------------------------------------------------------------------
' サブフォルダ・ファイルのリストアップ関数（再帰型）
'-----------------------------------------------------------------------
'［引数］
'   Sh         ：書き込み対象シート
'   RowCount   ：書き込み行数
'   ColumnCount：書き込み列数
'   FolderPath ：対象フォルダパス
'［戻り値］
'   True          ：成功
'   False         ：失敗
'［作成日］2013.06.18　［更新日］2023.11.19
' https://excel.syogyoumujou.com/vba/file_listup.html
'-----------------------------------------------------------------------
Function ListSubfoldersAndFiles(ByRef Sh As Worksheet, _
                                ByRef RowCount As Long, _
                                ByRef ColumnCount As Long, _
                                ByVal FolderPath As String) As Boolean
On Error GoTo ERROR_HANDLER
    Dim F                As Object
    Dim strSubFolderPath As String
    With CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)
        'サブフォルダ検索
        For Each F In .SubFolders
            'フォルダ名をセルに書き込み
            Sh.Cells(RowCount, ColumnCount).Value = "[" & F.Name & "]"
            RowCount = RowCount + 1
            ColumnCount = ColumnCount + 1
            
            'サブフォルダパス作成
            strSubFolderPath = FolderPath & Application.PathSeparator & F.Name
            
            '再帰
            If Not ListSubfoldersAndFiles(Sh, RowCount, ColumnCount, strSubFolderPath) Then
                GoTo ERROR_HANDLER
            End If
            ColumnCount = ColumnCount - 1
        Next
        
        'ファイル検索
        For Each F In .Files
            'ファイル名をセルに書き込み
            Sh.Cells(RowCount, ColumnCount).Value = F.Name
            RowCount = RowCount + 1
        Next
    End With
    ListSubfoldersAndFiles = True
ERROR_HANDLER:
    On Error GoTo 0
End Function