■以下コードでファイルを開かずにシート名をまとめて取得できる
呼び出し元コード
Sub 対象ファイルのシート名を取得() Dim arrSheetName() As String Dim strPath As String Dim i As Long strPath = "C:\Users\デスクトップ\test.xlsx" arrSheetName = fncGetSheets(strPath) For i = 0 To UBound(arrSheetName) Debug.Print arrSheetName(i) Next End Sub
呼び出し先コード
Function fncGetSheets(strFilePath As String) As String() '---------------------------------------------------------- '機 能:指定してファイルパス内のシート名を取得し配列にして返す '引 数:対象ファイルパス '戻り値:シート名の配列 '---------------------------------------------------------- Dim objCn As Object Dim objRs As Object 'Dim strFile As String Dim sSheet As String Dim i As Long Dim arrSheets() As String '---------------------------------------------------------- Set objCn = CreateObject("ADODB.Connection") Set objRs = CreateObject("ADODB.Recordset") With objCn .Provider = "Microsoft.ACE.OLEDB.12.0" .Properties("Extended Properties") = "Excel 12.0" .Open strFilePath 'ADODBを遅延バインディングしているためOpanSchemaの '定数「adSchemaTables」を値の「20」で指定する Set objRs = .OpenSchema(20) End With '-------------------------------------------------------- i = 1 Do Until objRs.EOF ReDim Preserve arrSheets(i - 1) sSheet = objRs.Fields("TABLE_NAME").Value If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then If Right(sSheet, 1) = "$" Then sSheet = Left(sSheet, Len(sSheet) - 1) End If If Right(sSheet, 2) = "$'" Then sSheet = Left(sSheet, Len(sSheet) - 2) End If If Left(sSheet, 1) = "'" Then sSheet = Mid(sSheet, 2) End If sSheet = Replace(sSheet, "''", "'") arrSheets(i - 1) = sSheet i = i + 1 End If objRs.MoveNext Loop objRs.Close objCn.Close Set objRs = Nothing Set objCn = Nothing fncGetSheets = arrSheets End Function
※参考URL
Excelファイルを開かずにシート名を取得|VBAサンプル集
OpenSchema メソッド (ADO) | Microsoft Docs
SchemaEnum (Access デスクトップ データベースリファレンス) | Microsoft Docs