mein Inhaltsverzeichnis mit Seitenanzahl erzeugen

Forumthread: mein Inhaltsverzeichnis mit Seitenanzahl erzeugen

25.05.2005 13:32:29

erkoo

Hallo Zusammen,
ich habe das folgende Makro mit dem ich einen Inhaltsverzeichnis als Hyperlink erzeuge.
Nun möchte ich in Spalte B die Seitenanzahl dazu angeben angeben.
Wie bekomme ich die Seitenanzahl der Tabellen die eingeblendet sind?
Ich habe dazu keine Idee.
Danke im Voraus!
Erko
Private Sub CommandButton1_Click() 'Sub MappenInhaltZusammenstellen() Dim Tabelle As Worksheet Dim i As Integer ActiveSheet.Name = "Inhaltsverzeichnis_neu" 'Inhaltsverzeichnis_neu 'Tabelle Cells(2, 1).Value = "Enthaltene Blätter als Hyperlinks" i = 3 For Each Tabelle In ActiveWorkbook.Worksheets If Tabelle.Name <> "Inhaltsverzeichnis_neu" Then Cells(i, 1).Value = Tabelle.Name Tabelle.Hyperlinks.Add Anchor:=Cells(i, 1), _ Address:="", SubAddress:=Tabelle.Name & _ "!A1", ScreenTip:="Hyperlink klicken", _ TextToDisplay:=Tabelle.Name Cells(i, 2).Value = Tabelle.Cells(1, 1).Value i = i + 1 End If Next Tabelle 'End Sub
End Sub

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Eine Alternative?

26.05.2005 09:42:25

Erich

Eine Alternative?

26.05.2005 09:42:25

Erich

Hallo Erko,
was hältst Du davon:
Option Explicit
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
zeile = 3
'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("A1")
.Value = "Inhaltsverzeichnis"
.Font.Name = "Arial"
.Font.Size = "18"
.Font.Bold = True
.Font.ColorIndex = 6
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Font.Underline = xlUnderlineStyleSingle
End With
With Cells(1, 2)
.Font.Name = "Arial"
.Font.Size = "18"
.Font.Bold = True
.Font.ColorIndex = 6
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With
With Cells(1, 3)
.Font.Name = "Arial"
.Font.Size = "18"
.Font.Bold = True
.Font.ColorIndex = 6
.Interior.ColorIndex = 5
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
End With

With Cells(2, 1)
.Value = "sortiert nach Blatt-Nr."
.Font.Name = "Arial"
.Font.Size = "16"
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
End With
With Cells(2, 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
Sheets("Inhaltsverzeichnis").Cells(zeile, 1).Value = "Blatt " & zeile - 2
Sheets("Inhaltsverzeichnis").Cells(zeile, 2).Value = Blatt.Name
Sheets("Inhaltsverzeichnis").Hyperlinks.Add Anchor:=Cells(zeile, 2), Address:="", SubAddress:="'" & _
Blatt.Name & "'!A1", TextToDisplay:=Blatt.Name
zeile = zeile + 1
Next Blatt
ActiveSheet.Columns("B:B").EntireColumn.AutoFit
'Kopiere die zwei erstellten Spalten und sortiere Hyperlinks
Range("A3", Range("B65536").End(xlUp)).Select
Selection.Copy
Range("D3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("D3", Range("E65536").End(xlUp)).Select
Selection.Sort Key1:=Range("E3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveSheet.Columns("D:E").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A3").Select
ActiveWindow.FreezePanes = True
Cells(1, 4).Value = "Diese Datei hat " & Worksheets.Count & " Tabellen"
'Userform ausblenden
'frmInhaltsverz.Hide
'Ursprungszustand wieder herstellen
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

mfg
Erich
EXCEL-Shareware und Freeware: http://www.toolex.de
EXCEL und Lottogewinne machen glücklich: http://48678.rapidforum.com

Beliebteste Forumthreads (12 Monate)

mein Inhaltsverzeichnis mit Seitenanzahl erzeugen

Forumthread: mein Inhaltsverzeichnis mit Seitenanzahl erzeugen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread