【Excel VBA】Dir関数でフォルダ内のファイル一覧を取得する方法｜拡張子指定・サブフォルダ対応

'========================================================
' 指定したフォルダ内にあるすべてのファイル名を取得する
'========================================================
Sub ファイル一覧を取得する()

    '検索するフォルダのパスを格納する変数
    Dim folderPath As String

    'Dir関数で取得したファイル名を格納する変数
    Dim fileName As String

    'VBAを記述しているブックと同じ場所にある
    '「テストフォルダ」を検索対象にする
    folderPath = ThisWorkbook.Path & "\テストフォルダ\"

    '「*.*」を指定してフォルダ内のファイルを取得する
    '最初のDir関数では検索するパスを指定する
    fileName = Dir(folderPath & "*.*")

    'ファイル名が取得できている間は処理を繰り返す
    Do While fileName <> ""

        '取得したファイル名をイミディエイトウィンドウへ表示する
        Debug.Print fileName

        '2件目以降は引数を指定せずDir関数を実行する
        '次のファイルが存在しない場合は空文字列が返される
        fileName = Dir()

    Loop

End Sub

'========================================================
' 指定したフォルダ内のファイルをExcelシートへ一覧出力する
' A列：ファイル名
' B列：ファイルのフルパス
'========================================================
Sub ファイル一覧をシートへ出力する()

    '検索するフォルダのパス
    Dim folderPath As String

    'Dir関数で取得したファイル名
    Dim fileName As String

    '結果を出力する行番号
    Dim rowNum As Long

    '検索対象となるフォルダを指定する
    folderPath = ThisWorkbook.Path & "\テストフォルダ\"

    '見出しを1行目に作成する
    Cells(1, 1).Value = "ファイル名"
    Cells(1, 2).Value = "フルパス"

    'データは2行目から出力する
    rowNum = 2

    'フォルダ内の最初のファイルを取得する
    fileName = Dir(folderPath & "*.*")

    'ファイルが取得できている間は繰り返す
    Do While fileName <> ""

        'A列へファイル名を出力する
        Cells(rowNum, 1).Value = fileName

        'B列へフォルダパスとファイル名を結合した
        'フルパスを出力する
        Cells(rowNum, 2).Value = folderPath & fileName

        '次のファイルを出力するため行番号を1つ増やす
        rowNum = rowNum + 1

        '次のファイル名を取得する
        fileName = Dir()

    Loop

End Sub

'========================================================
' フォルダ内にある「.xlsx」ファイルだけを一覧出力する
'========================================================
Sub Excelファイルだけを取得する()

    '検索対象となるフォルダのパス
    Dim folderPath As String

    'Dir関数で取得したファイル名
    Dim fileName As String

    '結果を出力する行番号
    Dim rowNum As Long

    '検索するフォルダを指定する
    folderPath = ThisWorkbook.Path & "\テストフォルダ\"

    '出力先の見出しを作成する
    Cells(1, 1).Value = "Excelファイル名"

    '2行目から結果を出力する
    rowNum = 2

    '「*.xlsx」を指定することで
    '拡張子が.xlsxのファイルだけを検索する
    fileName = Dir(folderPath & "*.xlsx")

    '該当するファイルがある間は処理を繰り返す
    Do While fileName <> ""

        '取得したExcelファイル名を出力する
        Cells(rowNum, 1).Value = fileName

        '次の出力行へ移動する
        rowNum = rowNum + 1

        '次の.xlsxファイルを取得する
        fileName = Dir()

    Loop

End Sub

'========================================================
' 指定したフォルダと、その配下にあるサブフォルダから
' すべてのファイルを取得してシートへ一覧出力する
'
' Dir関数は再帰的に呼び出せないため、
' 処理対象のフォルダをCollectionへ追加して順番に処理する
'========================================================
Sub サブフォルダを含めてファイル一覧を取得する()

    'これから確認するフォルダを保持するCollection
    Dim targetFolders As Collection

    '現在処理しているフォルダのパス
    Dim folderPath As String

    'ルートとなる最初のフォルダ
    Dim rootFolder As String

    '取得したファイル名
    Dim fileName As String

    '取得したサブフォルダ名
    Dim subFolderName As String

    '結果を出力する行番号
    Dim rowNum As Long

    'Collectionを作成する
    Set targetFolders = New Collection

    '最初に検索するフォルダを指定する
    rootFolder = ThisWorkbook.Path & "\テストフォルダ\"

    '最初に確認するフォルダとしてCollectionへ追加する
    targetFolders.Add rootFolder

    '出力先の見出しを作成する
    Cells(1, 1).Value = "フォルダ"
    Cells(1, 2).Value = "ファイル名"

    '2行目から結果を出力する
    rowNum = 2

    '確認するフォルダがなくなるまで処理を繰り返す
    Do While targetFolders.Count > 0

        'Collectionの先頭から処理対象のフォルダを取得する
        folderPath = targetFolders(1)

        '取得済みのフォルダはCollectionから削除する
        targetFolders.Remove 1

        '------------------------------------------------
        '現在のフォルダに存在するファイルを取得する
        '------------------------------------------------

        '現在のフォルダ内にある最初のファイルを取得する
        fileName = Dir(folderPath & "*.*")

        'ファイルが存在する間は繰り返す
        Do While fileName <> ""

            '念のため、取得した対象がフォルダではないことを確認する
            If (GetAttr(folderPath & fileName) And vbDirectory) = 0 Then

                'A列へファイルが保存されているフォルダを出力する
                Cells(rowNum, 1).Value = folderPath

                'B列へファイル名を出力する
                Cells(rowNum, 2).Value = fileName

                '次の出力行へ移動する
                rowNum = rowNum + 1

            End If

            '次のファイルを取得する
            fileName = Dir()

        Loop

        '------------------------------------------------
        '現在のフォルダに存在するサブフォルダを取得する
        '------------------------------------------------

        'vbDirectoryを指定して
        '現在のフォルダ内にある項目を取得する
        subFolderName = Dir(folderPath & "*", vbDirectory)

        '取得できる項目がある間は繰り返す
        Do While subFolderName <> ""

            '「.」と「..」は現在のフォルダと親フォルダを表すため除外する
            If subFolderName <> "." And subFolderName <> ".." Then

                '取得した項目がフォルダであることを確認する
                If (GetAttr(folderPath & subFolderName) And vbDirectory) = vbDirectory Then

                    '見つかったサブフォルダを
                    '次に確認するフォルダとしてCollectionへ追加する
                    targetFolders.Add folderPath & subFolderName & "\"

                End If

            End If

            '次の項目を取得する
            subFolderName = Dir()

        Loop

    Loop

End Sub