Excel VBA - Dropdown Menu to go to specific sheet - vba

Question

I want to make a dropdown that only contains 5/10 sheets that when i click on the sheet from the dropdown it proceeds to the sheet. At the moment I have a dropdown with all the sheets in it although I don't want them all.
Hopefully someone understands. Please feel free to ask for more information.
Thanks

Answer 1

This needs to be pasted on the sheet where the cell will change (not in a module). Be sure to swap "Sheet5" and "A2" in the code to the sheet name and cell range on your 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

Answer 2

This is a slightly different concept, which uses hyperlinks to navigate through a workbook. Hope it helps you out.
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