指定フォルダ内のファイル名一覧をExcelに書き出す2(再帰的に)…下位フォルダも対象

フォルダをダイアログで選択・指定したい場合は Shellオブジェクト(Shell.Application) 等を使えばいい。
    Office TANAKA - Excel VBA Tips[フォルダを選択するダイアログ]

'指定フォルダ内のファイル名一覧をExcelに書き出す2(再帰的に)…下位フォルダも対象
'参考
'第6回 指定フォルダ内のファイル名一覧をExcelに書き出す：ITpro
' <http://itpro.nikkeibp.co.jp/article/COLUMN/20060120/227645/>
' .sheet(1) → .ActiveSheetに変更
'＠IT：Windows TIPS -- Tips：ファイルの一覧情報リストを取得する
' <http://www.atmarkit.co.jp/fwin2k/win2ktips/310filelist/filelist.html>
 
Sub MakeFileList3()
 
    Application.EnableEvents = False 'イベントの禁止
    Application.ScreenUpdating = False
 
    strPath = InputBox("調べたいフォルダを絶対パスで入力してください。", "ファイル一覧", "\\server-001\folder1\subfolder2")
    'Target = "\\server-001\folder1\subfolder2"
 
    With ThisWorkbook.ActiveSheet
        'ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
 
        'シートのクリア
        Cells.ClearContents
        'Clear 全てクリア
        'ClearContents 数式､文字列をクリア
        'ClearFormats 書式をクリア
        'ClearComments コメント文をクリア
        'ClearOutline アウトラインをクリア
 
        '見出しを付ける
        .Range("B2") = "ファイル名"
        .Range("C2") = "親フォルダ名"
        .Range("D2") = "サイズ(KB)"
        .Range("E2") = "ファイル種別"
        .Range("F2") = "作成年月日"
        .Range("G2") = "最終アクセス年月日"
        .Range("H2") = "更新年月日"
        .Range("B2:H2").Interior.Color = RGB(0, 0, 0)
        .Range("B2:H2").Font.Color = RGB(255, 255, 255)
        .Range("B2:Es2").HorizontalAlignment = xlCenter
 
        i = 3
 
        FileDisp strPath, i
 
        Application.EnableEvents = True
        Application.ScreenUpdating = True '画面再描画再開
 
    End With
 
End Sub
 
Private Sub FileDisp(strPath, i)
 
    With ThisWorkbook.ActiveSheet
        Set objFs = CreateObject("Scripting.FileSystemObject")
        Set objFld = objFs.GetFolder(strPath)
        For Each objFl In objFld.Files
            '.Cells(i, 2) = objFs.GetBaseName(objFl.Path)
            .Cells(i, 2) = objFs.GetFileName(objFl.Path)
            .Cells(i, 3) = objFl.ParentFolder.Path
            .Cells(i, 4) = Int(objFl.Size / 1024)
            .Cells(i, 5) = objFl.Type
            .Cells(i, 6) = objFl.DateCreated
            .Cells(i, 7) = objFl.DateLastAccessed
            .Cells(i, 8) = objFl.DateLastModified
            i = i + 1
        Next
        For Each objSub In objFld.SubFolders
            FileDisp objSub.Path, i
        Next
    End With
 
End Sub