Excel対象ディレクトリ内のエクセルからシート名をがっつり取ってくる - Choc-Net!

Option Explicit

Private Sub CommandButton1_Click()
    Dim dirName As String
    Dim buf As String
    Dim rowIndex As Integer
    Dim strFileName As String
    Dim targetBook As Workbook
    Dim targetSheet As Worksheet
    Dim ws As Worksheet
    
    Const cnsDIR = "\*.xls" 'Excelファイルのみ抽出
    
    Application.ScreenUpdating = False
    
    'フォルダ選択ダイアログ表示
    With Application.FileDialog(msoFileDialogFolderPicker)
        '戻り値がない場合は処理を抜ける
        If Not .Show Then
            Exit Sub
        End If
        'ディレクトリパスを格納する
        dirName = .SelectedItems(1)
    End With
    
    'シートの挿入をする
    Worksheets.Add
    Set targetSheet = ActiveSheet
    
    rowIndex = rowIndex + 1
    
    'ディレクトリ名を表示する
    targetSheet.Cells(rowIndex, 1).Value = dirName
    
    ' 先頭のファイル名の取得
    strFileName = Dir(dirName & cnsDIR, vbNormal)
    
    ' ファイルが見つからなくなるまで繰り返す
    Do While strFileName <> ""
        
        Workbooks.Open dirName & "\" & strFileName
        Set targetBook = ActiveWorkbook
        
        'ブック名を指定して非表示
        Application.Windows(strFileName).Visible = False
        
       rowIndex = rowIndex + 1
        
        'エクセル名を表示する
        targetSheet.Cells(rowIndex, 2).Value = strFileName
        
        '全シート名を取得する。
        For Each ws In targetBook.Worksheets
            rowIndex = rowIndex + 1
            targetSheet.Cells(rowIndex, 3).Value = ws.Name
        Next
        
        'ブックを閉じる
        targetBook.Close SaveChanges:=False

        ' 次のファイル名を取得
        strFileName = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
    
    If MsgBox("シート取得ボタンの画面に戻りますか？", vbYesNo, "処理が完了しました。") = vbYes Then
        Sheet1.Select
    End If

End Sub