Fol­gende Auf­gabe ist gegeben: Auf dem ersten Blatt ein­er Arbeitsmappe mit dem Namen Über­sicht soll in Spalte A ein Index mit dem Namen aller restlichen Blät­ter erstellt wer­den. Jed­er dieser Ein­träge soll gle­ichzeit­ig ein Hyper­Link sein; ein Klick darauf, und das entsprechende Blatt wird zur aktuellen Tabelle. Die Zelle A1 soll die aktuelle Zelle sein.

Wenn Sie keine passende Mappe zur Hand haben, dann kön­nen Sie diese Mappe aus unserem Blog herun­ter­laden. Es ist eine Monat­süber­sicht ein­er Bäck­erei, welche son­st für andere Zwecke einge­set­zt wird. Fügen Sie in das Mod­ul DieseAr­beitsmappe Ihrer oder dieser Datei nun diesen Code ein:

Option Explicit
Option Base 1

Sub IndexHyperlinks()
   Dim IdxName As String, aShtNames(), Ze As Integer
   Dim wks As WorkSheet, bolIdx As Boolean, wksIdx As WorkSheet
   Dim x As Integer, Zelle As String, RueckVerweis As Boolean
   Dim dstRow As Long, i As Long
   
   'Blatt "Übersicht" erforderlichenfalls anlegen
   IdxName = "Übersicht"
   With ThisWorkbook
      For Each wks In .Sheets
         If wks.Name = IdxName Then
            bolIdx = True
            Exit For
         End If
      Next wks
      If Not bolIdx Then
         .Sheets.Add before:=Sheets(1)
         .ActiveSheet.Name = IdxName
      End If
      Set wksIdx = .Sheets(IdxName)
      
      'Blattnamen in Array schreiben
      ReDim aShtNames(.Sheets.Count - 1)
      For Each wks In .Sheets
         If wks.Name <> IdxName Then
            x = x + 1
            aShtNames(x) = wks.Name
         End If
      Next wks
      
      'IdxName: Alles löschen, dann Array schreiben
      With wksIdx
         .Cells.Delete
         .Cells(1, 1) = "Blatt-Übersicht"
         .Range(.Cells(2, 1), .Cells(x + 1, 1)) _
            = WorksheetFunction.Transpose(aShtNames)
      
         'Formatieren und als Hyperlink
         .Columns(1).EntireColumn.AutoFit
         With .Cells(1, 1)
            .Interior.Color = 5296274
            With .Borders(xlEdgeBottom)
               .LineStyle = xlContinuous
               .ColorIndex = 0
               .Weight = xlMedium
            End With
         End With
         For Ze = 2 To x + 1
            Zelle = .Cells(Ze, 1)
            .Hyperlinks.Add Anchor:=.Range("A" & Ze), Address:="", _
               SubAddress:=Zelle & "!A1"
         Next Ze
       End With
   End With
   
   'Auf jedem Blatt außer "Übersicht" einen Rück-Link zur Übersicht
   RueckVerweis = True  '<== oder False bzw. auskommentieren
   If RueckVerweis Then
      For i = 1 To UBound(aShtNames)
         Set wks = Sheets(aShtNames(i))
         With wks
            dstRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
               SearchDirection:=xlPrevious).Row + 2
            .Hyperlinks.Add Anchor:=.Cells(dstRow, 1), Address:="", _
               SubAddress:=IdxName & "!A1", TextToDisplay:="Zurück zur Übersicht"
         End With
      Next i
   End If
   
   'Nur weil's so schön ist :-)
   With wksIdx
      .Activate
      .Cells(1, 1).Select
   End With
End Sub

Zu Beginn wird geprüft, ob das Arbeits­blatt Über­sicht existiert. Bei Bedarf wird es an erster Stelle einge­fügt. Anschließend wer­den die Namen aller Arbeitsblätter/Register in ein Array gele­sen. Der Inhalt des Blatts Über­sicht wird dann kom­plett   gelöscht, in A1 eine Über­schrift geschrieben und  dann die Blat­tna­men ab Zelle A2 einge­tra­gen. Danach wer­den die Hyper­links aus den Zell-Ein­trä­gen ab Zeile 2 erzeugt. Kleinere For­matierun­gen run­den das Bild ab.

Um den Code nicht allzu sehr auszuweit­en, ist auf eine Prü­fung verzichtet wor­den, ob über­haupt aufzulis­tende Blät­ter existieren. Hier kön­nte eine Abfrage zu Beginn der Proze­dur einge­baut wer­den, ob auss­chließlich das Blatt Über­sicht existiert.

Hin­weis: Michael (siehe Kom­men­tar) hat mich auf einen Schreibfehler hingewiesen und auch eine sin­nvolle Ergänzung vorgeschla­gen. Danke dafür! – Der Code ist natür­lich kor­rigiert (exakt: Zeile gelöscht und am Ende neu konzip­iert)  und jet­zt dahinge­hend geän­dert, dass ein Rück-Ver­weis möglich ist (Default). Soll dieser  Link nicht einge­fügt wer­den, die Code-Zeile 60 auskom­men­tieren oder den Vari­ablen-Wert auf False set­zen.

▲ nach oben …

Rück­mel­dun­gen / Feed­back gerne per Mail an mich (G.Mumme@Excel-ist-sexy.de)

Hat Ihnen der Beitrag gefallen?
Erleichtert dieser Beitrag Ihre Arbeit?

Dann würde ich mich über einen Beitrag Ihrer­seits z.B. 1,50 € freuen … (← Klick mich!)