一時保存（後ほど削除予定）

Sub get_file_sheet()
    Dim fn(10000) 'フォルダ内ファイル名
    Dim sn(10000, 2) 'フォルダ内エクセルファイル名、シート名
    Dim i As Long, j As Long, k As Long, x As Long
    Dim mypath As String 'フォルダパス
    Dim ext As String '拡張子検索変数
    
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択"
        .AllowMultiSelect = False
        If .Show = -1 Then
            mypath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False '画面更新非表示
    
    'ファイル名の取得
    fn(1) = Dir(mypath & "\", vbDirectory)
    i = 1
    Do
        i = i + 1
        fn(i) = Dir
        
    Loop Until fn(i) = ""
    
    'シート名の取得
    x = 0
    For j = 1 To i - 1
        ext = Mid(fn(j), InStrRev(fn(j), ".") + 1, 3) '拡張子取得
        'エクセルファイルの時実行
        If ext = "xls" Then
            Workbooks.Open Filename:=mypath & "\" & fn(j)
            For k = 1 To Sheets.Count
                sn(x, 1) = fn(j) 'エクセルファイル名取得
                sn(x, 2) = Sheets(k).Name 'シート名取得
                x = x + 1
            Next k
            ActiveWorkbook.Close
        End If
    Next j
        
    'シート名一覧の作成
    Columns("A:B").Select
    Selection.ClearContents
    Cells(2, 1) = "作業フォルダ"
    Cells(3, 1) = mypath
    Cells(4, 1) = "ファイル名"
    Cells(4, 2) = "シート名"
    x = 0
    Do
        Cells(x + 5, 1) = sn(x, 1)
        Cells(x + 5, 2) = sn(x, 2)
        x = x + 1
    Loop Until sn(x, 1) = ""  
    
    Range("A1").Select
    
    Application.ScreenUpdating = True '画面更新表示
    
    MsgBox "完了しました"
    
End Sub