フォルダ内のエクセルファイルのシート一覧

Option Explicit
'フォルダ内のエクセルファイルのシート一覧作る。
Private Const BASEDIR As String = "C:\var"

Dim fso As New Scripting.FileSystemObject
Sub ogehogepon()
    Dim filelist() As String

    

    'fairuitiran

    ReDim filelist(0)

    Call GetFileList(BASEDIR, filelist)
    Dim dst As Worksheet

    Set dst = ActiveSheet

    Dim i As Long

    Dim j As Long

    Dim r As Long

    Dim wb As Workbook
    'Excelの窓を開きたくない→別インスタンスのExcelで開く

    '参考http://www.itlab51.com/?p=5346    

    Dim oxl As New Excel.Application

    Dim obk As Excel.Workbooks

    Set obk = oxl.Application.Workbooks
    r = 10

    For i = LBound(filelist) To UBound(filelist)

        

        Set wb = obk.Open(filelist(i), False, True)

        

        For j = 1 To wb.Sheets.Count

            dst.Cells(r, 1) = filelist(i)

            dst.Cells(r, 2) = wb.Sheets(j).name

            

            r = r + 1

        Next j

        Call wb.Close(SaveChanges:=False)

    Next i
End Sub
Sub GetFileList(TargetPath As String, ByRef filelist() As String)

    

    Dim fol As Object

    Set fol = fso.GetFolder(TargetPath)

    Dim f As Object

    Dim ext As String

    

    'このフォルダのファイル

    For Each f In fol.files

        

        ext = fso.GetExtensionName(f.name)

        If ext = "xls" Or ext = "xlsx" Then

        

            If UBound(filelist) = 0 And filelist(0) = "" Then

            Else

                ReDim Preserve filelist(UBound(filelist) + 1)

            End If

            

            filelist(UBound(filelist)) = f.Path

        

        End If

        

    Next

    

    'サブフォルダ

    For Each f In fol.SubFolders

        Call GetFileList(f.Path, filelist)

    Next

End Sub