Makro um Zellwert erweitern
06.04.2020 08:27:25
Tweety
ich habe vor geraumer Zeit ein Makro in diesem Formum erhalten welches ich gerne um einen Zellwert erweitern möchte.
Das Makro erstellt ein Inhaltsverzeichnis aller Tabellenblätter und verwendet als Überschrift die Zelle B3 eines jeden Tabellenblattes und ein zusätzlicher Link eingefügt.
Das Inhaltsverzeichnis sieht wie folgt aus:
Spalte A: Überschrift (aus Zellwert B3 jedes Tabellenblattes)
Spalte B: Link (zum Tabellenblatt, aus dem Tabellenblatt-Namen)
Ist es möglich das Inhaltsverzeichnis um den Wert V11 jeden Tabellenblattes in Spalte C zu erweitern?
Das Makro ist:
Sub INHALTSVERZEICHNIS()
' Inhalt_mit_Überschrift_aus_b3 Makro
' Erstellt ein Inhaltsverzeichnis aller Tabellenblaetter und verwendet als Überschrift die _
Zelle b3 eines jeden Tabellenblattes
Dim intTab As Integer
Dim tbl As Worksheet
Dim intZeile As Integer
Set tbl = Worksheets.Add(before:=Worksheets(1))
intZeile = 2
ActiveSheet.Name = Worksheets(1).Name
Cells(1, 1).Value = "Überschrift"
Cells(1, 2).Value = "Link"
Cells(1, 1).Font.Bold = True
Cells(1, 2).Font.Bold = True
For intTab = 2 To ActiveWorkbook.Worksheets.Count
tbl.Cells(intZeile, 1).Value = "='" & Worksheets(intTab).Name & "'!b3"
tbl.Cells(intZeile, 1).Font.Color = Worksheets(intTab).Tab.Color
tbl.Cells(intZeile, 2).Value = Worksheets(intTab).Name
tbl.Cells(intZeile, 2).Hyperlinks.Add _
Anchor:=tbl.Cells(intZeile, 2), Address:="", SubAddress:= _
"'" & Worksheets(intTab).Name & "'!b6", _
ScreenTip:="Klicken Sie um zur Tabelle zu gelangen", _
TextToDisplay:=Worksheets(intTab).Name
intZeile = intZeile + 1
Next intTab
Worksheets(1).Cells.EntireColumn.AutoFit
End Sub
Schöne Grüße