per VBA Inhaltsverzeichnis erstellen

Sub Inhalt_mit_Überschrift()
Dim intTab As Integer
Dim tbl As Worksheet
Dim intWS As Integer
Dim intZeile As Integer
' Bildschirmaktualisierung aufheben
Application.ScreenUpdating = False
' Fensterfixierung aufheben
Call DeleteFreezePanes
' Falls bereits ein Tabellenblatt mit dem Namen
' "Inhaltsverzeichnis" vorhanden ist, dieses löschen
For Each tbl In Worksheets
If tbl.Name = "Inhaltsverzeichnis" Then
Application.DisplayAlerts = False
tbl.Delete
Application.DisplayAlerts = True
End If
Next tbl
Set tbl = Worksheets.Add(Before:=Worksheets(1))
Worksheets(1).Name = "Inhaltsverzeichnis"
Cells.Interior.ColorIndex = 2
Columns("A:A").NumberFormat = "@"
intZeile = 5
' Zellenüberschriften
ActiveSheet.Name = Worksheets(1).Name
Cells(4, 1).Value = "Kassenkonto"
Cells(4, 2).Value = "Steuerpflichtiger"
Cells(4, 1).Font.Bold = True
Cells(4, 2).Font.Bold = True
Cells(4, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
Cells(4, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
Cells(4, 1).Borders(xlEdgeBottom).Weight = xlMedium
Cells(4, 2).Borders(xlEdgeBottom).Weight = xlMedium
For intTab = 2 To ActiveWorkbook.Worksheets.Count
' In jedem Tabellenblatt die Navigationszeile
' mit Link zum Inhaltsverzeichnis erstellen
With Worksheets(intTab)
' Alte Navigationszeile löschen
If .Range("I1").Value = "Inhaltsverzeichnis" Then
.Rows(1).Delete
End If
' Neue Navigationszeile einfügen
.Rows(1).Insert
.Hyperlinks.Add _
Anchor:=.Range("I1"), _
Address:="", _
SubAddress:="Inhaltsverzeichnis!I1", _
TextToDisplay:="Inhaltsverzeichnis"
End With
'Setzen eines Hyperlinks auf Tabellenblatt
tbl.Cells(intZeile, 1).Value = Worksheets(intTab).Name
tbl.Cells(intZeile, 1).Hyperlinks.Add _
Anchor:=tbl.Cells(intZeile, 1), Address:="", SubAddress:= _
"'" & Worksheets(intTab).Name & "'!A2", _
ScreenTip:="Klicken Sie um zur Tabelle zu gelangen", _
TextToDisplay:=Worksheets(intTab).Name
' Ausgabe der Zelle A1 eines jeden Arbeitsblattes als Überschrift
tbl.Cells(intZeile + 1, 2).Value = "='" & Worksheets(intTab).Name & "'!a2"
intZeile = intZeile + 1
Next intTab
Worksheets(1).Cells.EntireColumn.AutoFit
Worksheets("Inhaltsverzeichnis").Move Before:=Worksheets(1)
' Fensterfixierung festlegen
Call AddFreezePanes
' Das Tabellenblatt "Inhaltsverzeichnis" aktivieren
Worksheets(1).Activate
SchaltflächeIntegrieren
' Bildschirmaktualisierung wieder aktivieren
Application.ScreenUpdating = True
End Sub