Home | Contact Us | FAQ | Search & Site Map | Link to Us
Sign In | Join | Other 45 Sites in Network
Home
DiscussionsAccessExcelInfoPathOutlookPowerPointPublisherWord
DirectoryUser Groups
Related Topics
Outlook ExpressInternet ExplorerWindowsMS Server ProductsMore Topics ...

MS Office Forum / Excel / Worksheet Functions / May 2008

Tip: Looking for answers? Try searching our database.

on your main page click on the worksheet name and be taken to it

Thread view: 
Enable EMail Alerts  Start New Thread
Thread rating: 
chiefrockeruk - 20 May 2008 12:54 GMT
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
Gary Brown - 20 May 2008 13:41 GMT
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
'/=============================================/
Gord Dibben - 20 May 2008 17:40 GMT
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
 
Sign In
Join
My Latest Posts
My Monitored Threads
My Blog
My Photo Gallery
My Profile
My Homepage

Start New Thread
Enable EMail Alerts
Rate this Thread



©2008 Advenet LLC   Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.