This will create a Table of Contents page with hyperlinks to each worksheet.
Hope it helps.
Sincerely,
Gary Brown
'/=============================================/
' Sub Purpose:
' Create a separate worksheet with the name of each sheet
' in the workbook as a hyperlink to that sheet -
' i.e. a Table Of Contents
' 07/25/2000 - allow for chart sheets
' 08/11/2005 - add Protect/Unprotect information
'
'
Public Sub TableOfContents()
Dim blnContinue As Boolean
Dim iRow As Integer, iColumn As Integer
Dim i As Integer, x As Integer, iSheets As Integer
Dim iType As Integer
Dim objOutputArea As Object
Dim strTableName As String, strSheetName As String
Dim strTypeName As String
Dim varAnswer As Variant
On Error GoTo err_Sub
strTableName = "Table of Contents1"
blnContinue = True
'check for an active workbook
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If
'Count number of sheets in workbook
iSheets = ActiveWorkbook.Sheets.Count
'Check for duplicate Sheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Sheets(x).name) = UCase(strTableName) Then
blnContinue = False
Sheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
varAnswer = _
MsgBox("Do you wish to delete the current <<< " & _
strTableName & " >>> worksheet?", _
vbInformation + vbYesNoCancel + vbDefaultButton1, _
"Warning..." & strTableName & " already exists...")
If varAnswer = vbYes Then
blnContinue = True
'turn warning messages off
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
'turn warning messages on
Application.DisplayAlerts = True
End If
Exit For
End If
Next
If blnContinue = True Then
'Add new sheet at end of workbook
' where results will be located
Sheets.Add.Move Before:=Sheets(1)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = _
"Worksheet (hyperlink)"
ActiveWorkbook.ActiveSheet.Range("B1").value = _
"Visible / Hidden"
ActiveWorkbook.ActiveSheet.Range("C1").value = _
"Prot / Un / Tab Color"
ActiveWorkbook.ActiveSheet.Range("D1").value = _
" Notes: "
ActiveWorkbook.ActiveSheet.Range("E1").value = _
" Type: "
'Count number of sheets in workbook
iSheets = ActiveWorkbook.Sheets.Count
'Initialize row and column counts for putting
' info into StrTableName sheet
iRow = 1
iColumn = 0
Set objOutputArea = _
ActiveWorkbook.Sheets(strTableName).Range("A1")
'Check Sheet names
For x = 1 To iSheets
strSheetName = Sheets(x).name
'put information into StrTableName worksheet
With objOutputArea
If strSheetName <> strTableName Then
.Offset(iRow, iColumn) = " " & strSheetName
If UCase(TypeName(Sheets(x))) <> "CHART" Then
Sheets(x).Hyperlinks.Add _
Anchor:=objOutputArea.Offset(iRow, _
iColumn), _
Address:="", SubAddress:=Chr(39) & _
strSheetName & Chr(39) & "!A1"
End If
If Application.VERSION >= 11 Then
.Offset(iRow, iColumn + 2).Interior.ColorIndex = _
Sheets(x).Tab.ColorIndex
End If
Select Case Sheets(x).Visible
Case xlSheetVisible
.Offset(iRow, iColumn + 1) = " Visible"
.Offset(iRow, iColumn).Font.Bold = True
.Offset(iRow, iColumn + 1).Font.Bold = True
Case xlSheetHidden
.Offset(iRow, iColumn + 1) = " Hidden"
Case xlSheetVeryHidden
.Offset(iRow, iColumn + 1) = " Very Hidden"
End Select
If Sheets(x).ProtectContents = True Then
.Offset(iRow, iColumn + 2) = " P"
Else
.Offset(iRow, iColumn + 2) = " U"
End If
iType = Sheets(x).Type
strTypeName = TypeName(Sheets(x))
.Offset(iRow, iColumn + 4) = _
fncWorksheetType(iType, strTypeName)
iRow = iRow + 1
End If
End With
Next x
Sheets(strTableName).Activate
'make comment
Range("C1").AddComment
With Range("C1").Comment
.Visible = False
.Text Text:= _
"Protected / Unprotected Worksheet / Tab Color"
End With
'format worksheet
Range("A:E").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
With Selection.Font
.name = "Tahoma"
'.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Range("A1").Font.Bold = True
Columns("A:E").EntireColumn.AutoFit
Range("A1:E1").Select
With Selection
.HorizontalAlignment = xlCenter
.Font.Underline = xlUnderlineStyleSingle
End With
Range("B1").Select
With ActiveCell.Characters(Start:=1, Length:=7).Font
.FontStyle = "Bold"
End With
With ActiveCell.Characters(Start:=8, Length:=9).Font
.FontStyle = "Regular"
End With
Columns("A:E").EntireColumn.AutoFit
Range("A1:E1").Font.Underline = _
xlUnderlineStyleSingleAccounting
Range("B:B").HorizontalAlignment = xlCenter
Range("C1").WrapText = True
Columns("C:C").HorizontalAlignment = xlCenter
Rows("1:1").RowHeight = 100
Columns("C:C").ColumnWidth = 9.75
Rows("1:1").EntireRow.AutoFit
Range("D1").HorizontalAlignment = xlLeft
Columns("D:D").ColumnWidth = 65
'format print options
On Error Resume Next
Call PageSetupXL4( _
CenterHead:="&B" & "&16&U&F - [&A]", _
CenterFoot:="Page &P of &N", _
LeftMarginInches:=0.75, _
RightMarginInches:=0.75, _
TopMarginInches:=1, _
BottomMarginInches:=0.75, _
HeaderMarginInches:=0.5, _
FooterMarginInches:=0.5, _
PrintGridlines:=True, _
Orientation:=xlLandscape, _
CenterHorizontally:=True, _
Zoom:=True, _
Order:=xlOverThenDown)
With ActiveSheet.PageSetup
.PrintArea = "$A:$D"
.FitToPagesWide = 1
.FitToPagesTall = False
If .PrintTitleRows = "" Then
.PrintTitleRows = "$1:$1"
End If
If .PaperSize <> xlPaperLetter And _
.PaperSize <> xlPaperLegal Then
.PaperSize = xlPaperLetter '1
End If
End With
Range("A1").Select
Selection.AutoFilter
Application.Dialogs(xlDialogWorkbookName).Show
End If
exit_Sub:
On Error Resume Next
Application.DisplayAlerts = True
Exit Sub
err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: TableOfContents - " & _
"Module: Mod_Table_Of_Contents - " & Now()
If Err.Number = 1004 Then
MsgBox "The Workbook (" & Chr(34) & _
Application.ActiveWorkbook.name & _
Chr(34) & ") is protected. A " & _
"'Table of Contents' worksheet could not be " & _
"created. Please unprotect the " & _
"Workbook and try again.", _
vbInformation + vbOKOnly, "Warning..."
End If
If Err.Number = 438 Then
iType = 9999
Resume Next
End If
GoTo exit_Sub
End Sub
'/=============================================/
' Function Purpose: return the worksheet type
'
Public Function fncWorksheetType(iType As Integer, _
strTypeName As String) As String
Dim strResult As String
On Error GoTo err_Function
Select Case strTypeName
Case "Worksheet"
Select Case iType
Case xlWorksheet ' -4167
strResult = strTypeName
Case xlExcel4MacroSheet ' 3
strResult = "Excel4 Macro"
Case xlExcel4IntlMacroSheet ' 4
strResult = "Excel4 Intl Macro"
Case Else
strResult = "Unknown"
End Select
Case "Chart"
strResult = strTypeName
Case "DialogSheet"
strResult = strTypeName
Case Else
strResult = "Unknown"
End Select
fncWorksheetType = strResult
exit_Function:
On Error Resume Next
Exit Function
err_Function:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Function: fncWorksheetType - " & _
"Module: Mod_Table_Of_Contents - " & Now()
fncWorksheetType = "Unknown"
GoTo exit_Function
End Function
'/=============================================/
You can right-click on the navigation arrows at lower left to see a list of 15
sheets plus"more sheets".
One other method is to set up an index sheet with hyperlinks to sheets or do
what I prefer................
Use VBA code from Bob Phillips..............
Sub BrowseSheets()
Const nPerColumn As Long = 38 'number of items per column
Const nWidth As Long = 13 'width of each letter
Const nHeight As Long = 18 'height of each row
Const sID As String = "___SheetGoto" 'name of dialog sheet
Const kCaption As String = " Select sheet to goto"
'dialog caption
Dim i As Long
Dim TopPos As Long
Dim iBooks As Long
Dim cCols As Long
Dim cLetters As Long
Dim cMaxLetters As Long
Dim cLeft As Long
Dim thisDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim cb As OptionButton
Application.ScreenUpdating = False
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.DialogSheets(sID).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set CurrentSheet = ActiveSheet
Set thisDlg = ActiveWorkbook.DialogSheets.Add
With thisDlg
.Name = sID
.Visible = xlSheetHidden
'sets variables for positioning on dialog
iBooks = 0
cCols = 0
cMaxLetters = 0
cLeft = 78
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
If i Mod nPerColumn = 1 Then
cCols = cCols + 1
TopPos = 40
cLeft = cLeft + (cMaxLetters * nWidth)
cMaxLetters = 0
End If
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
cLetters = Len(CurrentSheet.Name)
If cLetters > cMaxLetters Then
cMaxLetters = cLetters
End If
iBooks = iBooks + 1
.OptionButtons.Add cLeft, TopPos, cLetters * nWidth, 16.5
.OptionButtons(iBooks).text = _
ActiveWorkbook.Worksheets(iBooks).Name
TopPos = TopPos + 13
Next i
.Buttons.Left = cLeft + (cMaxLetters * nWidth) + 24
CurrentSheet.Activate
With .DialogFrame
.Height = Application.Max(68, _
Application.Min(iBooks, nPerColumn) * nHeight + 10)
.Width = cLeft + (cMaxLetters * nWidth) + 24
.Caption = kCaption
End With
.Buttons("Button 2").BringToFront
.Buttons("Button 3").BringToFront
Application.ScreenUpdating = True
If .Show Then
For Each cb In thisDlg.OptionButtons
If cb.Value = xlOn Then
ActiveWorkbook.Worksheets(cb.Caption).Select
Exit For
End If
Next cb
Else
MsgBox "Nothing selected"
End If
Application.DisplayAlerts = False
.Delete
End With
End Sub
Gord Dibben MS Excel MVP
>i have created many worksheets in my excel workbook, my first page lists all
>the worksheets and i want to be ables to click on one of the worksheet titles
>in my list and be taken straight to it.
>
>i am currentley looking at my list and then looking along the bottom for the
>relavent worksheet to the list