超簡単！フォルダからファイル名を自動取得一覧化する

Option Explicit

Sub ファイル名()
    Dim Shell As Object, FPath As String
    Dim i, Fname As String
    Dim MB As Workbook
    Dim Patha As String, DA As Variant
        Set MB = ThisWorkbook
        Set Shell = CreateObject("Shell.Application") _
            .BrowseForFolder(0, "フォルダを選択してください", 0, CurDir)
'キャンセルを選択
        If Shell Is Nothing Then
            FPath = ""
            MsgBox "フォルダ選択がキャンセルされました。" _
                        , vbExclamation
            Exit Sub
        Else
'フォルダを選択し「OK」をクリック
'選択したフォルダのフルパスを入手
            FPath = Shell.Items.Item.Path
        End If
        Patha = FPath & "\"
'Dir関数を使う
        Fname = Dir(Patha & "*.xls*")
'スタート行番号設定変数
        i = 0
'すべてのファイルが検索されるまで
        Do While Fname <> ""
            i = i + 1
            MB.Activate
            Worksheets("Sheet1").Select
            Cells(i, 1).Value = Fname
'再検査します
            Fname = Dir()
        Loop
        Worksheets("Sheet1").Columns(1).AutoFit
        MsgBox "全部で" & i & "個ファイルがありました"
End Sub

        Set Shell = CreateObject("Shell.Application") _
            .BrowseForFolder(0, "フォルダを選択してください", 0, CurDir)

        If Shell Is Nothing Then
            FPath = ""

'Dir関数を使う
        Fname = Dir(Patha & "*.xls*")

'すべてのファイルが検索されるまで
        Do While Fname <> ""
            i = i + 1
            MB.Activate
            Worksheets("Sheet1").Select
            Cells(i, 1).Value = Fname
'再検査します
            Fname = Dir()
        Loop

'吸い上げるデータの変数化して宣言
    Dim ValA As Variant
'フォルダ内のそれぞれのファイルを開く
       Workbooks.Open (FPath & "\" & Fname)
'データの有るセルを指定して変数に代入
       ValA = Worksheets("Sheet1").Range("B11")
'BOOKのフォーカスを元に戻す
       MB.Activate
'ピッキングしたデータの置き場所に移動
       Worksheets("Sheet1").Select
       Cells(i, 2) = ValA
'データを吸い取った後そのファイルを閉じる
       Workbooks(Fname).Close False