Sub GetListOfSheets() 'список листов (и именованнных диапазонов) их закрытого файла
Dim fName$, i As Long, rc As Long, y
Dim sPrv As String, sConStr As String
Dim f$, arr()

With Application.FileDialog(msoFileDialogFilePicker)
 .Title = "Please select a file": .InitialFileName = ThisWorkbook.Path
 .Filters.Add "Excel", "*.xls;*.xlsx;*.xlsm", 1: .AllowMultiSelect = False
 If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
 fName = .SelectedItems(1)
End With

If Val(Application.Version) < 12 Then
 sPrv = "Microsoft.Jet.OLEDB.4.0": sConStr = "Data Source=" & fName & ";Extended Properties=Excel 8.0;"
Else
 sPrv = "Microsoft.ACE.OLEDB.12.0": sConStr = "Data Source=" & fName & ";Extended Properties=Excel 12.0;"
End If

With New ADODB.Connection
 .Provider = sPrv: .ConnectionString = sConStr: .CursorLocation = adUseClient: .Open
 With .OpenSchema(adSchemaTables)
 ' With .OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))' or so
 rc = .RecordCount
 ReDim arr(1 To rc + 1, 1 To 2)
 arr(1, 1) = "#Sheets": arr(1, 2) = fName
 For i = 1 To rc
 arr(i + 1, 1) = i: arr(i + 1, 2) = Replace(.Fields("TABLE_NAME").Value, "$", "")
 .MoveNext
 Next i
 .Close
 End With
 .Close
End With
Range("A1").CurrentRegion.ClearContents
Range("A1:B1").Resize(UBound(arr)).Value = arr()
End Sub