Folgende Aufgabe ist gegeben: Auf dem ersten Blatt einer Arbeitsmappe mit dem Namen Übersicht soll in Spalte A ein Index mit dem Namen aller restlichen Blätter erstellt werden. Jeder dieser Einträge soll gleichzeitig ein Hyperlink 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önnen Sie diese Mappe aus unserem Blog herunterladen. Es ist eine Monatsübersicht einer Bäckerei, welche sonst für andere Zwecke eingesetzt wird. Fügen Sie in das Modul DieseArbeitsmappe 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 Arbeitsblatt Übersicht existiert. Bei Bedarf wird es an erster Stelle eingefügt. Anschließend werden die Namen aller Arbeitsblätter/Register in ein Array gelesen. Der Inhalt des Blatts Übersicht wird dann komplett   gelöscht, in A1 eine Überschrift geschrieben und  dann die Blattnamen ab Zelle A2 eingetragen. Danach werden die Hyperlinks aus den Zell-Einträgen ab Zeile 2 erzeugt. Kleinere Formatierungen runden das Bild ab.

Um den Code nicht allzu sehr auszuweiten, ist auf eine Prüfung verzichtet worden, ob überhaupt aufzulistende Blätter existieren. Hier könnte eine Abfrage zu Beginn der Prozedur eingebaut werden, ob ausschließlich das Blatt Übersicht existiert.

Hinweis: Michael (siehe Kommentar) hat mich auf einen Schreibfehler hingewiesen und auch eine sinnvolle Ergänzung vorgeschlagen. Danke dafür! – Der Code ist natürlich korrigiert (exakt: Zeile gelöscht und am Ende neu konzipiert)  und jetzt dahingehend geändert, dass ein Rück-Verweis möglich ist (Default). Soll dieser  Link nicht eingefügt werden, die Code-Zeile 60 auskommentieren oder den Variablen-Wert auf False setzen.

▲ nach oben …

Rückmeldungen / Feedback 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 Ihrerseits z.B. 1,50 € freuen … (← Klick mich!)