AW: Inhaltsverzeichnis erstellen
15.12.2009 23:57:51
Josef
Hallo René,
probier mal.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Function GetSheetNames(ByVal File 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 varTmp() As Variant
If Dir(File, vbNormal) = "" Then Exit Function
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=Excel 8.0;"
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 varTmp(lngIndex)
varTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = varTmp
objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Sub createLinks()
Dim rng As Range, objHL As Hyperlink
Dim lngRow As Long, lngFirstRow As Long, lngLastRow As Long
Dim lngIndex As Long, lngCol As Long, vntSheets As Variant
lngFirstRow = 2 'erste Datenzeile - Anpassen!
lngCol = 1 'Spalte mit den Hyperlinks - Anpassen!
With Sheets("Tabelle1") 'Tabellenname - Anpassen!
lngLastRow = Application.Max(lngFirstRow, .Cells(Rows.Count, 1).End(xlUp).Row)
lngRow = lngFirstRow
For Each objHL In .Range(.Cells(lngFirstRow, 1), .Cells(lngLastRow, 1)).Hyperlinks
vntSheets = GetSheetNames(objHL.Address)
If IsArray(vntSheets) Then
For lngIndex = 0 To UBound(vntSheets)
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=objHL.Address & "#" & vntSheets(lngIndex) & "!A1", _
SubAddress:="", _
TextToDisplay:=objHL.Address & "#" & vntSheets(lngIndex) & "!A1"
lngRow = lngRow + 1
Next
End If
Next
.Range(.Cells(lngFirstRow, 1), .Cells(.Rows.Count, 1)).Delete xlToLeft
.Columns(1).AutoFit
End With
End Sub
Gruß Sepp