Codeänderung: Dateien und Blätter auflisten

Option Explicit
Sub linkXLFilesAndSheets()
Dim strPath As String, strFile As String
Dim lngRow As Long, lngIndex As Long
Dim vntSheets As Variant
Range("A3:IV" & Rows.Count).Clear
strPath = Range("B1")
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
lngRow = 3
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While strFile  ""
Me.Hyperlinks.Add anchor:=Cells(lngRow, 1), _
Address:=strPath & strFile, _
SubAddress:="", TextToDisplay:=strFile
vntSheets = GetSheetNames(strPath & strFile)
For lngIndex = 0 To UBound(vntSheets)
Me.Hyperlinks.Add anchor:=Cells(lngRow, lngIndex + 2), _
Address:=strPath & strFile & "#" & vntSheets(lngIndex) & _
"!A1", SubAddress:="", TextToDisplay:=vntSheets(lngIndex)
Next
lngRow = lngRow + 1
strFile = Dir
Loop
Me.Columns.AutoFit
End Sub
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
Dim strConString As String, strTable As String
Dim vntTmp() As Variant
'If Dir(FileName, vbNormal) = "" Then Exit Function
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR= _
YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
ReDim Preserve vntTmp(lngIndex)
vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = vntTmp
objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function