シート目次（ジャンプ付き）を作成する

ブック内のシートの目次を作成するマクロです。目次項目からは各シートにジャンプできます。

もらったExcelファイルを開いてみると、シートの数が数十も。しかもそれらを識別するためシート名もそれぞれ長い。横スクロールしながらのシート探しを繰り返し…。　そんなときに利用しています。

Public Sub シート目次作成()
  Const wsName As String = "シート目次"
  Dim myWS As Worksheet
  Dim aryName() As String
  Dim cnt As Long, i As Long
  Dim flgErr As Boolean

  cnt = Worksheets.Count
  If cnt = 1 Then flgErr = True

  ReDim aryName(1 To cnt)
  For i = 1 To cnt
    If Worksheets(i).Name = wsName Then
      flgErr = True
      Exit For
    End If
    aryName(i) = Worksheets(i).Name
  Next i
    
  If flgErr = True Then
    MsgBox "シートが一つしかないか、[" & wsName & "]シートがすでに存在しています", _
           vbExclamation + vbOKOnly
    Exit Sub
  End If
    
  Set myWS = Worksheets.Add(Before:=Worksheets(1))
  myWS.Name = wsName
    
  With myWS.Range("A1")
    .Value = wsName & ":"
    .Offset(0, 1).Value = myWS.Parent.Name
    For i = 1 To cnt
      .Offset(i, 0).Value = i
      .Offset(i, 1).Value = "[" & aryName(i) & "]"
      myWS.Hyperlinks.Add _
        Anchor:=.Offset(i, 1), _
        Address:="", _
        SubAddress:=Chr(39) & aryName(i) & Chr(39) & "!A1"
    Next i
  End With
  Set myWS = Nothing
End Sub