Fol­gende Auf­gabe ist ge­ge­ben: Auf dem ers­ten Blatt ein­er Ar­beits­map­pe mit dem Na­men Über­sicht soll in Spal­te A ein In­dex mit dem Na­men al­ler rest­li­chen Blät­ter er­stellt wer­den. Jed­er die­ser Ein­träge soll gle­ichzeit­ig ein Hyper­Link sein; ein Klick dar­auf, und das ent­spre­chen­de Blatt wird zur ak­tu­el­len Ta­bel­le. Die Zel­le A1 soll die ak­tu­el­le Zel­le sein.

Wenn Sie kei­ne pas­sen­de Map­pe zur Hand ha­ben, dann kön­nen Sie die­se Map­pe aus un­se­rem Blog herun­ter­laden. Es ist eine Monat­süber­sicht ein­er Bäck­erei, wel­che son­st für an­de­re Zwe­cke einge­set­zt wird. Fü­gen Sie in das Mod­ul DieseAr­beitsmappe Ih­rer oder die­ser Da­tei nun die­sen 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 Be­ginn wird ge­prüft, ob das Arbeits­blatt Über­sicht exis­tiert. Bei Be­darf wird es an ers­ter Stel­le einge­fügt. An­schlie­ßend wer­den die Na­men al­ler Ar­beits­blät­ter/Re­gis­ter in ein Ar­ray gele­sen. Der In­halt des Blatts Über­sicht wird dann kom­plett   ge­löscht, in A1 eine Über­schrift ge­schrie­ben und  dann die Blat­tna­men ab Zel­le A2 einge­tra­gen. Da­nach wer­den die Hyper­links aus den Zell-Ein­trä­gen ab Zei­le 2 er­zeugt. Klei­ne­re For­matierun­gen run­den das Bild ab.

Um den Code nicht all­zu sehr auszuweit­en, ist auf eine Prü­fung ver­zich­tet wor­den, ob über­haupt aufzulis­tende Blät­ter exis­tie­ren. Hier kön­nte eine Ab­fra­ge zu Be­ginn der Proze­dur einge­baut wer­den, ob auss­chließlich das Blatt Über­sicht exis­tiert.

Hin­weis: Mi­cha­el (sie­he Kom­men­tar) hat mich auf ei­nen Schreib­feh­ler hin­ge­wie­sen und auch eine sin­nvolle Er­gän­zung vorgeschla­gen. Dan­ke da­für! – Der Code ist natür­lich kor­rigiert (ex­akt: Zei­le ge­löscht und am Ende neu konzip­iert)  und jet­zt dahinge­hend geän­dert, dass ein Rück-Ver­weis mög­lich ist (De­fault). Soll die­ser  Link nicht einge­fügt wer­den, die Code-Zei­le 60 auskom­men­tieren oder den Vari­ablen-Wert auf Fal­se set­zen.

▲ nach oben …

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

Hat Ih­nen der Bei­trag ge­fal­len?
Er­leich­tert die­ser Bei­trag Ihre Ar­beit?

Dann wür­de ich mich über ei­nen Bei­trag Ihrer­seits z.B. 1,50 € freu­en … (← Klick mich!)