Excel VBA - раскрывающееся меню для перехода к определенному листу

Это нужно вставить на лист, где ячейка изменится (не в модуле). Не забудьте поменять местами «Sheet5» и «A2» в коде на имя листа и диапазон ячеек в вашем Excel.

Sub Worksheet_Change(ByVal Target As Range)

  If Intersect(Target, ThisWorkbook.Sheets("Sheet5").Range("A2")) Is Nothing Then Exit Sub
        Application.EnableEvents = False
            On Error GoTo Stopsub:
            Call ChangeSheet
Stopsub:
Application.EnableEvents = True


End Sub

Sub ChangeSheet()

        Dim SelectedSheet As String
        SelectedSheet = ThisWorkbook.Sheets("Sheet5").Range("A2")
        ThisWorkbook.Sheets(SelectedSheet).Activate

End Sub

Это немного другая концепция, которая использует гиперссылки для навигации по книге. Надеюсь, это поможет вам.

Sub BuildTOC_A3()
   Cells(3, 1).Select
   BuildTOC
End Sub
Sub BuildTOC()
  'listed from active cell down 7-cols --  DMcRitchie 1999-08-14 2000-09-05
  Dim iSheet As Long, iBefore As Long
  Dim sSheetName As String, sActiveCell As String
  Dim cRow As Long, cCol As Long, cSht As Long
  Dim lastcell
  Dim qSht As String
  Dim mg As String
  Dim rg As Range
  Dim CRLF As String
  Dim Reply As Variant
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  cRow = ActiveCell.Row
  cCol = ActiveCell.Column
  sSheetName = UCase(ActiveSheet.Name)
  sActiveCell = UCase(ActiveCell.Value)
  mg = ""
  CRLF = Chr(10)  'Actually just CR
  Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
  rg.Select
  If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
  If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
  If mg <> "" Then
     mg = "Warning BuildTOC will destructively rewrite the selected area" _
     & CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
      & "the affected area will be rewritten, or" & CRLF & _
      "Press CANCEL to check area then reinvoke this macro (BuildTOC)"
     Application.ScreenUpdating = True  'make range visible
     Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
      & " items in workbook" & Chr(10) & "revised will now occupy up to 10 columns")
     Application.ScreenUpdating = False
     If Reply <> 1 Then GoTo AbortCode
  End If
  rg.Clear      'Clear out any previous hyperlinks, fonts, etc in the area
  For cSht = 1 To ActiveWorkbook.Sheets.Count
     Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
     If TypeName(Sheets(cSht)) = "Worksheet" Then
        'hypName = "'" & Sheets(csht).Name
        ' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace not in XL97
        qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
        If CDbl(Application.Version) < 8# Then
          '-- use next line for XL95
          Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name  'XL95
        Else
          '-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
          Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).CodeName

          '--- excel is not handling lots of objects well ---
          'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _
          '  Address: = "", SubAddress: = "'" & Sheets(cSht).Name & "'!A1"
          '--- so will use the HYPERLINK formula instead ---
          '--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
          ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
            "=hyperlink(""[" & ActiveWorkbook.Name _
            & "]'" & qSht & "'!A1"",""" & qSht & """)"
        End If
     Else
       Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
     End If
     Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
    ' -- activate next line to include content of cell A1 for each sheet
    ' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
     On Error Resume Next
     Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
     If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
     Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
     Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
     Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
     On Error GoTo 0
  Next cSht

  'Now sort the results:  2. Type(D), 1. Name (A), 3. module(unsorted)
  rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
      , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
  rg.Columns.AutoFit
  rg.Select           'optional
  'if cells above range are blank want these headers
  ' Worksheet,   Type,    codename
  If cRow > 1 Then
     If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
        Cells(cRow - 1, cCol) = "Worksheet"
        Cells(cRow - 1, cCol + 1) = "Type"
        Cells(cRow - 1, cCol + 2) = "CodeName"
        Cells(cRow - 1, cCol + 3) = "[opt.]"
        Cells(cRow - 1, cCol + 4) = "Lastcell"
        Cells(cRow - 1, cCol + 5) = "cells"
        Cells(cRow - 1, cCol + 6) = "ScrollArea"
        Cells(cRow - 1, cCol + 7) = "PrintArea"
     End If
  End If
  Application.ScreenUpdating = True
  Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
     "Would you like the tabs in workbook also sorted", _
     vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
     & " tabs in workbook")
  Application.ScreenUpdating = False
  'If Reply = 1 Then SortALLSheets  'Invoke macro to Sort Sheet Tabs
  Sheets(sSheetName).Activate
AbortCode:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub