Function listI(name As String) As String
Application.Volatile
listI = Workbooks(name).ActiveSheet.name
End Function

Function GetSheetsNames(WBName As String) As Collection
'Needs a reference to:
'Microsoft ActiveX Data Object X.X Library
'Microsoft ADO Ext. X.X for DLL and Security

Dim objConn As ADODB.Connection
Dim objCat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim sConnString As String
Dim sSheet As String
Dim Col As New Collection

sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & WBName & ";" & _
"Extended Properties=Excel 8.0;"

Set objConn = New ADODB.Connection
objConn.Open sConnString
Set objCat = New ADOX.Catalog
Set objCat.ActiveConnection = objConn

For Each tbl In objCat.Tables
sSheet = tbl.name
sSheet = Application.Substitute(sSheet, "'", "")
sSheet = Left(sSheet, InStr( 1 , sSheet, "$",  1 ) -  1 )
On Error Resume Next
Col.Add sSheet, sSheet
On Error GoTo  0 
Next tbl
Set GetSheetsNames = Col
objConn.Close
Set objCat = Nothing
Set objConn = Nothing
End Function

Sub Test()
Dim Col As Collection, Book As String, i As Long
Book = "C:\...\Price.xls"
Set Col = GetSheetsNames(Book)
For i =  1  To Col.Count
MsgBox Col(i)
Next i
End Sub

Function listI(name As String) As String
Dim Col As Collection, Book As String, i As Long
Application.Volatile
On Error GoTo L1:
listI = Workbooks(name).ActiveSheet.name
Exit Function
L1:
Book = "C:\...\" & name
Set Col = GetSheetsNames(Book)
For i =  1  To Col.Count
listI = Col(i)
Next i
End Function

'Microsoft ActiveX Data Object X.X Library
'Microsoft ADO Ext. X.X for DLL and Security