Hello,
I'm looking for a macro that will create a table of contents, with hyperlinks, for each worksheet in my file.
I found the following macro below, although the hyperlinks it creates are folder and computer specific. I would like to adjust this macro, so the hyperlinks are dynamic and will work for other users of the file. Possibly by creating hyperlink formulas with the # symbol?
Anyone have any thoughts on how to do this?
http://vbaexpress.com/kb/getarticle.php?kb_id=120
<B>Macro:</B>
I'm looking for a macro that will create a table of contents, with hyperlinks, for each worksheet in my file.
I found the following macro below, although the hyperlinks it creates are folder and computer specific. I would like to adjust this macro, so the hyperlinks are dynamic and will work for other users of the file. Possibly by creating hyperlink formulas with the # symbol?
Anyone have any thoughts on how to do this?
http://vbaexpress.com/kb/getarticle.php?kb_id=120
<B>Macro:</B>
Code:
Option Explicit
Sub CreateTOC()
'Declare all variables
Dim ws As Worksheet, curws As Worksheet, shtName As String
Dim nRow As Long, i As Long, N As Long, x As Long, tmpCount As Long
Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String
Dim cCnt As Long, cAddy As String, cShade As Long
'Check if a workbook is open or not. If no workbook is open, quit.
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'-------------------------------------------------------------------------------
cShade = 37 '<<== SET BACKGROUND COLOR DESIRED HERE
'-------------------------------------------------------------------------------
'Turn off events and screen flickering.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nRow = 4: x = 0
'Check if sheet exists already; direct where to go if not.
On Error Goto hasSheet
Sheets("TOC").Activate
'Confirm the desire to overwrite sheet if it exists already.
If MsgBox("You already have a Table of Contents page. Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then Goto createNew
Exit Sub
hasSheet:
x = 1
'Add sheet as the first sheet in the workbook.
Sheets.Add before:=Sheets(1)
Goto hasNew
createNew:
Sheets("TOC").Delete
Goto hasSheet
hasNew:
'Reset error statment/redirects
On Error Goto 0
'Set chart sheet varible counter
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
'Set a little formatting for the TOC sheet.
ActiveSheet.Name = "TOC"
With Sheets("TOC")
.Cells.Interior.ColorIndex = cShade
.Rows("4:65536").RowHeight = 16
.Range("A1").Value = "Designed by VBAX"
.Range("A1").Font.Bold = False
.Range("A1").Font.Italic = True
.Range("A1").Font.Name = "Arial"
.Range("A1").Font.Size = "8"
.Range("A2").Value = "Table of Contents"
.Range("A2").Font.Bold = True
.Range("A2").Font.Name = "Arial"
.Range("A2").Font.Size = "24"
.Range("A4").Select
End With
'Set variables for loop/iterations
N = ActiveWorkbook.Sheets.Count + tmpCount
If x = 1 Then N = N - 1
For i = 2 To N
With Sheets("TOC")
'Check if sheet is a chart sheet.
If IsChart(Sheets(i).Name) Then
'** Sheet IS a Chart Sheet
cCnt = cCnt + 1
shtName = Charts(cCnt).Name
.Range("C" & nRow).Value = shtName
.Range("C" & nRow).Font.ColorIndex = cShade
'Set variables for button dimensions.
cLeft = .Range("C" & nRow).Left
cTop = .Range("C" & nRow).Top
cWidth = .Range("C" & nRow).Width
cHeight = .Range("C" & nRow).RowHeight
cAddy = "R" & nRow & "C3"
'Add button to cell dimensions.
Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
cLeft, cTop, cWidth, cHeight)
cb.Select
'Use older technique to add Chart sheet name to button text.
ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
'Format shape to look like hyperlink and match background color (transparent).
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = 0
With .Font
.Underline = xlUnderlineStyleSingle
.ColorIndex = 5
End With
.ShapeRange.Fill.Visible = msoFalse
.ShapeRange.Line.Visible = msoFalse
.OnAction = "Mod_Main.GotoChart"
End With
Else
'** Sheet is NOT a Chart sheet.
shtName = Sheets(i).Name
'Add a hyperlink to A1 of each sheet.
.Range("C" & nRow).Hyperlinks.Add _
Anchor:=.Range("C" & nRow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range("C" & nRow).HorizontalAlignment = xlLeft
End If
.Range("B" & nRow).Value = nRow - 2
nRow = nRow + 1
End With
continueLoop:
Next i
'Perform some last minute formatting.
With Sheets("TOC")
.Range("C:C").EntireColumn.AutoFit
.Range("A4").Activate
End With
'Turn events back on.
Application.DisplayAlerts = True
Application.ScreenUpdating = True
strMsg = vbNewLine & vbNewLine & "Please note: " & _
"Charts will have hyperlinks associated with an object."
'Toggle message box for chart existence or not, information only.
If cCnt = 0 Then strMsg = ""
MsgBox "Complete!" & strMsg, vbInformation, "Complete!"
End Sub
Public Function IsChart(cName As String) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
Dim tmpChart As Chart
On Error Resume Next
'If not a chart, this line will error out.
Set tmpChart = Charts(cName)
'Function will be determined if the variable is now an Object or not.
IsChart = IIf(tmpChart Is Nothing, False, True)
End Function
Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
Dim obj As Object, objName As String
'With the button text as the Chart name, we use the Caller method to obtain it.
Set obj = ActiveSheet.Shapes(Application.Caller)
'The latter portion of the AlternativeText will give us the exact Chart name.
objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
InStr(1, obj.AlternativeText, ": ")))
'Then we can perform a standard Chart sheet Activate method using the variable.
Charts(objName).Activate
'Optional: zoom Chart sheet to fit screen.
'Depending on screen resolution, this may need adjustment(s).
ActiveWindow.Zoom = 80
End Sub
