The easiest thing would be Insert > Hyperlink > Place in this document...then
type in the cell reference...probably A1.
If you really want a macro to do this...
Link your button to this macro:
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
That will call this...
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
HTH,
Ryan
