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

'-----------------------------------------------------------------------
' 指定フォルダ配下のサブフォルダとファイルを新規ブックにリストアップ
'-----------------------------------------------------------------------
'［作成日］2013.06.18　［更新日］2025.05.03
' https://excel.syogyoumujou.com/vba/file_listup.html
'-----------------------------------------------------------------------
Sub Main_Sub()

    '-------------------------
    ' フォルダの選択
    '-------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択してください"
        If .Show Then
            ' フォルダパスを変数に代入
            strFolderPath = .SelectedItems(1)
        Else
            ' 「キャンセル」ボタンをクリックした場合は終了
            Exit Sub
        End If
    End With
    If Dir(strFolderPath, vbDirectory) = "" Then
        ' フォルダの存在が確認できない場合は終了
        MsgBox "選択したフォルダは対象外です", vbExclamation, "中止します"
        Exit Sub
    End If
    
    '-------------------------
    ' 新規ブック準備
    '-------------------------
    Application.ScreenUpdating = False
    
    ' 新規ブックのシートをオブジェクト変数にセット
    Dim sht As Worksheet
    Set sht = Workbooks.Add.Worksheets(1)
    
    ' セルA1にフォルダパスを出力
    sht.Cells(1, 1).Value = "[" & strFolderPath & "]"
    
On Error GoTo LBL_ERROR
    
    '《サブフォルダ・ファイルのリストアップ》
    ' ** 引数1：出力対象シート
    ' ** 引数2：出力行番号
    ' ** 引数3：出力列番号
    ' ** 引数4：対象フォルダパス
    Call createListSubfoldersAndFiles(sht, 2, 2, strFolderPath)
    
    Application.ScreenUpdating = True
    
    MsgBox "リストアップ終了", vbOKOnly + vbInformation
    Exit Sub
   
'---------------------------
' エラー処理
'---------------------------
LBL_ERROR:
    MsgBox "ソース：" & Err.Source & vbLf & _
           "エラー番号：" & Err.Number & vbLf & _
           Err.Description, _
           vbCritical, "エラーが発生しました"
End Sub

'-----------------------------------------------------------------------
' サブフォルダ・ファイルのリストアップ（再帰関数）
'-----------------------------------------------------------------------
'［引数］
'   sht           ：出力対象シート
'   NumberOfRow   ：出力行番号
'   NumberOfColumn：出力列番号
'   FolderPath    ：対象フォルダパス
'［作成日］2013.06.18　［更新日］2025.05.03
' https://excel.syogyoumujou.com/vba/file_listup.html
'-----------------------------------------------------------------------
Sub createListSubfoldersAndFiles(ByRef sht As Worksheet, _
                                 ByRef NumberOfRow As Long, _
                                 ByRef NumberOfColumn As Long, _
                                 ByVal FolderPath As String)
On Error Resume Next

    ' ファイルシステムオブジェクト生成
    Dim fsoFolder As Object
    Set fsoFolder = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)
    
    '---------------------------
    ' アクセス制限確認
    '---------------------------
    Dim lngCount As Long
    lngCount = fsoFolder.SubFolders.Count
    ' フォルダのアクセス制限によるエラー対応
    If Err.Number <> 0 Then
        Err.Clear
        sht.Cells(NumberOfRow, NumberOfColumn).Value = "アクセス制限"
        NumberOfRow = NumberOfRow + 1
        GoTo LBL_FINALLY
    End If
    
On Error GoTo LBL_ERROR
    
    '---------------------------
    ' サブフォルダ検索
    '---------------------------
    Dim F                As Object
    Dim strSubFolderPath As String
    For Each F In fsoFolder.SubFolders
        'フォルダ名をセルに出力
        sht.Cells(NumberOfRow, NumberOfColumn).Value = "[" & F.Name & "]"
        NumberOfRow = NumberOfRow + 1
        NumberOfColumn = NumberOfColumn + 1
        
        ' サブフォルダパス作成
        strSubFolderPath = FolderPath & Application.PathSeparator & F.Name
        
        '《サブフォルダ・ファイルのリストアップ》（再帰）
        Call createListSubfoldersAndFiles(sht, NumberOfRow, NumberOfColumn, strSubFolderPath)
            
        NumberOfColumn = NumberOfColumn - 1
    Next
    
    '---------------------------
    ' ファイル検索
    '---------------------------
    For Each F In fsoFolder.Files
        'ファイル名をセルに出力
        sht.Cells(NumberOfRow, NumberOfColumn).Value = F.Name
        NumberOfRow = NumberOfRow + 1
    Next

LBL_FINALLY:
    Set fsoFolder = Nothing
    Exit Sub
    
'---------------------------
' エラー処理
'---------------------------
LBL_ERROR:
    Set fsoFolder = Nothing
    If Err.Source = "VBAProject" Then Err.Source = FolderPath
    Call Err.Raise(Err.Number, Err.Source, Err.Description)
End Sub