Sub СОЗДАТЬ_ОГЛАВЛЕНИЕ()   ' создание В АКТИВНОЙ КНИГЕ листа оглавления с гиперссылками на все её листы
      Dim shName$: shName = "<<ОГЛАВЛЕНИЕ>>"   ' название создаваемого листа оглавления
      Dim sStartCell$: sStartCell = "B2"   ' первая ячейка, начиная с которой выводятся гиперссылки
      If ActiveWorkbook.ProtectStructure Then MsgBox "Структура книги защищена" & vbLf & "Создать лист оглавления невозможно", vbExclamation: Exit Sub
      Dim oWbk As Workbook: Set oWbk = ActiveWorkbook
      Dim iSht As Worksheet, rCell As Range
      Dim sCode$, sProc1$, sProc2$
      On Error Resume Next
      Set iSht = oWbk.Worksheets(shName)
      If iSht Is Nothing Then  ' если листа shName в книге нет, то создать его и прописать на него VBA-код обработки событий
          Application.ScreenUpdating = False: Application.EnableEvents = False
          sProc1 = "Private Sub Worksheet_Activate()" & vbLf & _
                   "   Dim iSht As Worksheet" & vbLf & _
                   "   On Error Resume Next" & vbLf & _
                   "   For Each iSht In ThisWorkbook.Worksheets   ' скрываем все листы кроме ActiveSheet" & vbLf & _
                   "      If iSht.Visible <> xlSheetVeryHidden Then iSht.Visible = iSht.Name = ActiveSheet.Name" & vbLf & _
                   "   Next" & vbLf & _
                   "End Sub"
          sProc2 = "Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)" & vbLf & _
                   "   Dim sHypAddr$, sParent$, iSht As Worksheet" & vbLf & _
                   "   On Error Resume Next" & vbLf & _
                   "   Application.ScreenUpdating = False: Application.EnableEvents = False" & vbLf & _
                   "   sHypAddr = Target.SubAddress" & vbLf & _
                   "   sParent = Replace$(Mid$(sHypAddr, 1, InStr(sHypAddr, ""!"") - 1), ""'"", """")" & vbLf & _
                   "   For Each iSht In ThisWorkbook.Worksheets" & vbLf & _
                   "      If iSht.Visible <> xlSheetVeryHidden Then iSht.Visible = IIf(Target.TextToDisplay = ""Все листы"", True, (iSht.Name = sParent) Or (iSht.Name = Target.Range.Parent.Name))" & vbLf & _
                   "   Next" & vbLf & _
                   "   Target.Follow" & vbLf & _
                   "   Application.EnableEvents = True: Application.ScreenUpdating = True" & vbLf & _
                   "End Sub"
          sCode = sProc1 & vbLf & vbLf & sProc2
          oWbk.Worksheets.Add: ActiveSheet.Name = shName
          Dim sCodeName$: sCodeName = ActiveSheet.CodeName
          Dim VBComp As Object
          Set VBComp = ActiveWorkbook.VBProject.VBComponents(sCodeName)
          VBComp.CodeModule.InsertLines VBComp.CodeModule.CountOfDeclarationLines + 1, sCode
      End If
      Application.ScreenUpdating = False: Application.EnableEvents = False
      With oWbk.Sheets(shName)
          .Range(sStartCell).EntireColumn.ClearContents   ' очистить столбец для вывода оглавления
          .Move Before:=oWbk.Sheets(1)
          For Each iSht In oWbk.Sheets   ' прописываем гиперссылки на все листы книги на листе shName
              If iSht.Visible <> xlSheetVeryHidden Then
                  Set rCell = .Range(sStartCell).Offset(iSht.Index - 1, 0)
                  .Hyperlinks.Add Anchor:=rCell, Address:="", SubAddress:="'" & iSht.Name & "'" & "!A1", ScreenTip:="Перейти на лист """ & iSht.Name & """"
                  rCell.Formula = IIf(iSht.Name = shName, "Все листы", iSht.Name)
                  iSht.Visible = iSht.Name = shName
              End If
          Next
      End With
      Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub