Solved: Macro to Add Link to Each Worksheet?

[Smartkid]

Hi,

I'm using the following Macro from a file that someone who no longer works at my firm used in his spreadsheets. Basically, it creates a Table of Contents for the all the worksheets in the file.

I want to modify the Macro to add a link to the table of contents tab on each of the worksheets in Cell A2. Can anyone help? I tried to decipher what's going on in the code but was unable to.

Thanks

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 = "TITLE"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Name = "Arial"
        .Range("A1").Font.Size = "24"
        .Range("A2").Value = "Month: "
        .Range("A2").Font.Bold = False
        .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

[Simon Lloyd]

Do you want a hyperlink back to the table of contents on every sheet?, how many sheets? you could do this manually vey quickly.

[Smartkid]

Hi Simon,

I have to create a new Excel file each month and this month's contained 223 worksheets.

The Macro already creates the 'TOC' which links to each of the worksheets. Since there are so many worksheets, I would like to had a hyperlink back to the 'TOC' in Cell A2 of each worksheet to make navigating through the file easier.

It would be too much work to do manually. I tried to Select All Worksheets and then paste the hyperlink so that it carries through to all the sheets but Excel doesn't let me do it.

Since the Macro already traverses through all the spreadsheets in the workbook, I thought it would be easy to add a few lines in the code that would add the link to the TOC as it goes along.

Thanks

[Simon Lloyd]

This should do what you need, create a module and add this [VBA]
sub linkit()
Dim Sh As Worksheet
For Each Sh In Sheets
If Sh.Name = "TOC" Then
Else
Sheets(Sh.Name).Hyperlinks.Add Anchor:=Sheets(Sh.Name).Range("A2"), Address:="", SubAddress:= _
"TOC!A1", TextToDisplay:="Table of contents"
End If
Next Sh
End Sub
[/VBA]

after this line in your code ActiveWindow.Zoom = 80, add Call linkit

[Smartkid]

Thanks! It works.

[Simon Lloyd]

If this is solved then please mark it that way by going to THREAD TOOLS>MARK SOLVED