指定フォルダ(下位フォルダ含む)内のExcelブック(ファイル)のシート名をExcelに書き出す。 recursive

同一フォルダのExcelブック(ファイル)のシート名を一覧にするというのはネットでもあったが、
下位フォルダをも対象とするものは日本語はもちろん、英語でも検索したが探しきれなかった。
それ以上、探すより作った方が早いと思ったので、以前作ったのをちょっと修正して作った。

調べてないがVisioもシート名(ページ名)をVBAで取得できるんじゃないかと思う。

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

'指定フォルダ(下位フォルダ含む)内のExcelブック(ファイル)のシート名をExcelに書き出す recursive
 
''対応済み。気にしなくていい→   '指定フォルダに"このExcelブック(ファイル)"は置かないこと。さもなくばOpenでエラーとなる。
'"このExcelブック(ファイル)"は処理の対象外とする
'フォルダの階層、Excelブック(ファイル)数、シート数によっては処理時間やPCの空きメモリに注意すること
 
'' 参考
''第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>
 
Option Explicit
Sub MakeFileList4()
 
    Dim strPath, I
 
    Application.EnableEvents = False 'イベントの禁止
    Application.ScreenUpdating = False
 
    strPath = InputBox("調べたいフォルダを絶対パスで入力してください。", "ファイル一覧, シート一覧", "\\server-001\folder1\subfolder2")
    'Target = "\\server-001\folder1\subfolder2"
    'Target = "C:\Documents and Settings\UserName\My Documents\test"
 
    With ThisWorkbook.ActiveSheet
        'ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
 
        'シートのクリア
        Cells.ClearContents
        'Clear 全てクリア
        'ClearContents 数式､文字列をクリア
        'ClearFormats 書式をクリア
        'ClearComments コメント文をクリア
        'ClearOutline アウトラインをクリア
 
        .Range("B1").Value = "調査日時" & " " & Date & " " & Time
 
        '見出しを付ける
        .Range("B2") = "ファイル名"
        .Range("C2") = "フォルダ名"
        '.Range("C2") = "フルパス(リンク)"
        .Range("D2") = "サイズ(KB)"
        .Range("E2") = "ファイル種別"
        .Range("F2") = "作成年月日"
        .Range("G2") = "最終アクセス年月日"
        .Range("H2") = "更新年月日"
 
        .Range("I2") = "シート名"
 
        .Range("B2:I2").Interior.Color = RGB(0, 0, 0)
        .Range("B2:I2").Font.Color = RGB(255, 255, 255)
        .Range("B2:Es2").HorizontalAlignment = xlCenter
 
        I = 3
 
        FileDisp strPath, I
 
        '.Columns("B:I").AutoFit
        .Columns("B:C").AutoFit
        .Columns("I").AutoFit
 
        Application.EnableEvents = True
        Application.ScreenUpdating = True '画面再描画再開
 
    End With
 
End Sub
 
Private Sub FileDisp(strPath, I)
    Dim objFS, objFLD, objFL, objSub
 
    With ThisWorkbook.ActiveSheet
        Set objFS = CreateObject("Scripting.FileSystemObject")
        Set objFLD = objFS.GetFolder(strPath)
        For Each objFL In objFLD.Files
 
''If objFL.Type = "Microsoft Excel ワークシート" Then  '@@@Excel のみを処理対象とするときはコメントを外すこと(コメント時はWord,Project,Visio,PDF,テキスト等全てのファイル種別を対象とする)
 
            .Cells(I, 2) = objFS.GetBaseName(objFL.Path)
            .Cells(I, 2) = objFS.GetFileName(objFL.Path)
            '.Cells(I, 3) = "<" & objFL & ">"
            .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
 
' ***
            If objFL.Type = "Microsoft Excel ワークシート" And objFL <> ThisWorkbook.FullName Then  'Excel のときのみシート名を出力する
 
                Dim J, K, M As Integer, wb2 As Workbook
 
                J = I
                Set wb2 = Workbooks.Open(objFL, ReadOnly:=True) '読取専用で開く
                'Set wb2 = Workbooks.Open(objFL) '普通に開く
 
                K = wb2.Worksheets.Count
 
                For M = 1 To K
 
                    '非表示のシートを強制的に再表示させる
                    If  wb2.Worksheets(M).Visible = False Then
                        wb2.Worksheets(M).Visible = True
                        .Cells(J, 11) = "シート非表示"
                    End If
 
                    wb2.Worksheets(M).Select
                        If wb2.Worksheets(M).Name <> "" Then
                            .Cells(J, 9) = wb2.Worksheets(M).Name
 
                            '空のワークシート は "未使用(空)" と表示する
                            If IsEmpty(wb2.Worksheets(M).UsedRange) = True Then
                                '.Cells(J, 9) = wb2.Worksheets(M).Name & " " & "未使用(空)"
                                .Cells(J, 10) = "未使用(空)"
 
                                If wb2.Worksheets(M).Shapes.Count <> 0 Then 'スクリーンイメージを貼り付けただけのときに「未使用(空)」と出力されないように
                                   .Cells(J, 10) = "図形(オブジェクト)あり"
                                End If
 
                            End If
 
                            J = J + 1
 
                        End If
                Next M
 
                wb2.Close SaveChanges:=False
 
                J = J - 1
                I = J
            End If
 
' ***
 
            I = I + 1
 
''End If                                               '@@@Excel のみを処理対象とするときはコメントを外すこと
 
        Next
        For Each objSub In objFLD.SubFolders
            FileDisp objSub.Path, I
        Next
 
    End With
 
End Sub