Erweiterung Inhaltsverzeichnis
25.09.2015 07:53:56
erichm
habe nachstehenden Code, mit dem ich eine Tabelle Inhaltsverzeichnis erstellen lasse und es werden wunderbar alle Tabellen der Datei aufgelistet; nach Nrn. (Spalten A und B) und nach Alphabet (Spalten D und E):
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
In Spalte F soll in der jeweiligen Zeile die letzte aktive Zelle der Tabelle gem. Spalte E eingetragen werden. Die Ermittlung dieser Zelle würde mit
Sub leZelle()
MsgBox "Die neue letzte Zelle besitzt die Adresse " & _
Cells.SpecialCells(xlLastCell).Address(False, False) & ".", vbInformation
End Sub
funktionieren.
So sollte dies aussehen:
https://www.herber.de/bbs/user/100386.xlsx
Besten Dank für eine Hilfe.
mfg