AW: Inhaltsverzeichnis mit Hyperlinks per Makro
27.11.2008 22:13:00
Ramses
Hallo
Alternativ vielleicht so
Sub Create_Hyperlink_Table_of_Contents()
'(C) Ramses
'Erstellt ein Inhaltsverzeichnis auf alle Tabellen einer
'Mappe mit Hyperlinks auf die jeweiligen Tabellen
Dim tarWks As Worksheet
Dim i As Integer, myRow As Integer, tmpCnt As Integer
'Blattnamen anpassen
Set tarWks = Worksheets("Inhalt")
'Bestehenden Inhalt löschen
tarWks.Columns(1).ClearContents
tarWks.Cells(1, 1) = "Inhalt"
'Erstellen des Inhaltsverzeichnisses
'**************************
'Vertikal
For i = 2 To Worksheets.count
tarWks.Cells(i, 1) = Worksheets(i).name
Cells(i, 1).Hyperlinks.Add Anchor:=Cells(i, 1), Address:="", SubAddress:="'" & Worksheets(i).name & "'!A1", TextToDisplay:=Worksheets(i).name
Next i
'Sortiert das Inhaltsverzeichnis
tarWks.Columns(1).Sort Key1:=tarWks.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'**************************
'Horizontal
'tmpCnt = 1
'myRow = 1
'For i = 1 To Worksheets.Count
' If i Mod 256 = 0 Then
' tmpCnt = 1
' myRow = myRow + 1
' End If
' If Worksheets(i).Name <> tarwks.Name Then
' tarwks.Cells(myRow, tmpCnt) = Worksheets(i).Name
' Cells(myRow, tmpCnt).Hyperlinks.Add Anchor:=Cells(myRow, tmpCnt), Address:="", SubAddress:="'" & Worksheets(i).Name & "'!A1", TextToDisplay:=Worksheets(i).Name
' tmpCnt = tmpCnt + 1
' End If
'Next i
End Sub
Gruss Rainer