You Look Too Cool

Sub シート名一覧の作成()
    Dim fn(1000)
    Dim sn(10000, 10)
   
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択"
        .AllowMultiSelect = False
        If .Show = -1 Then
            mypath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
   
    'ファイル名の取得
    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:=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
       
    'シート名一覧の作成
    Cells.ClearContents
    Cells(1, 1) = mypath
    Cells(3, 1) = "ファイル名"
    Cells(3, 2) = "シート名"
    x = 0
    Do
        Cells(x + 4, 1) = sn(x, 1)
        Cells(x + 4, 2) = sn(x, 2)
        x = x + 1
    Loop Until sn(x, 1) = ""
End Sub