Link auf Diagramm
19.07.2005 16:24:55
Timo
Ich hoffe Ihr könnt mir helfen. Ich habe mir vor einiger Zeit aus dem Forum ein Makro zum anlegen eines Inhaltsverzeichnisses kopiert. Soweit sogut. Es lief bisher auch tadellos. Nun habe ich in meinen Excelfiles aber einige Tabellenblätter, die ein Diagramm sind (Diagramm erstellt und als Speicherort neues Tabelleblatt angegeben). Das Inhaltsverzeichnis erstellt sich weiterhin ohne Probleme, jedoch funktionieren die Links auf die Tabellenblätter mit den Diagrammen nicht und Excel steigt aus. Alle anderen Tabelleblätter können weiterhin ohne Probleme aufgerufen werden.
Woran kann das liegen?
Hat jemand vielleicht einen Tipp, wie ich das hinbekomme, finde nämlich keinen Fehler.
Anbei der Code des Makros.
Danke schon einmal vorab,
Timo
Sub inhaltsverzeichnis_erstellen()
'Inhaltsverzeichnis aller Tabellenblätter
'im erten Tabellenblatt ab Zeile A1 einfügen
Dim Blatt As Object
Dim zeile As Double
Dim NewSheet As Worksheet
Dim i As Integer
Dim Name As String
zeile = 5
'Fehlerhandling
On Error Resume Next
'Abfrage unterdrücken
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Sheet Inhaltsverzeichnis auf jeden Fall löschen
Sheets("Inhaltsverzeichnis").Delete
'Neues Tabellenblatt mit dem Namen Inhaltsverzeichnis hinzufügen
Set NewSheet = Worksheets.Add
NewSheet.Name = "Inhaltsverzeichnis"
Sheets("Inhaltsverzeichnis").Move Before:=Sheets(1) ' = Tabellenblatt als erstes
'Überschrift Einfügen und formatieren
With Sheets("Inhaltsverzeichnis").Range("B1")
.Value = "Inhaltsverzeichnis"
.Font.Underline = xlUnderlineStyleSingle
End With
For i = 1 To 5
With Cells(1, i)
.Font.Name = "Arial"
.Font.Size = "18"
.Font.Bold = True
.Font.ColorIndex = 6
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
Next i
With Cells(3, 1)
.Value = "Sortiert nach Blatt-Nr."
.Font.Name = "Arial"
.Font.Size = "16"
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
End With
With Cells(3, 5)
.Value = "Alphabetisch sortiert"
.Font.Name = "Arial"
.Font.Size = "16"
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
End With
'Laufende Blattnummerierung + Blattname einfügen
For Each Blatt In Sheets
'If Blatt.Name "Inhaltsverzeichnis" Then
Sheets("Inhaltsverzeichnis").Cells(zeile, 1).Value = "Blatt " & zeile - 4
Sheets("Inhaltsverzeichnis").Cells(zeile, 1).Font.Size = "12"
Sheets("Inhaltsverzeichnis").Cells(zeile, 2).Value = Blatt.Name
Sheets("Inhaltsverzeichnis").Hyperlinks.Add Anchor:=Cells(zeile, 2), Address:="", SubAddress:="'" & _
Blatt.Name & "'!A1", TextToDisplay:=Blatt.Name
Sheets("Inhaltsverzeichnis").Cells(zeile, 2).Font.Size = "12"
zeile = zeile + 1
'End If
Next Blatt
ActiveSheet.Columns("B:B").EntireColumn.AutoFit
'Kopiere die zwei erstellten Spalten und sortiere Hyperlinks
Range("A5", Range("B65536").End(xlUp)).Select
Selection.Copy
Range("D5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("D5", Range("E65536").End(xlUp)).Select
Selection.Sort Key1:=Range("E5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveSheet.Columns("D:E").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A4").Select
ActiveWindow.FreezePanes = True
Cells(1, 4).Select
Name = "Inhaltsverzeichnis"
With ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.CodeName).CodeModule
.InsertLines 1, "
Private Sub Workbook_Open()"
.InsertLines 2, "Sheets(" & Name & ").Activate"
.InsertLines 3, "End Sub
End With
'Ursprungszustand wieder herstellen
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Anzeige