Create a gist now

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Generate a hyperlinked table of contents linking to each sheet in an Excel workbook (blog post: http://blog.richpollock.com/2014/11/generating-a-hyperlinked-table-of-contents-for-an-excel-workbook-using-vba/)
Sub GenerateLinkedTOCFromWorkSheetNames()
Dim ProposedTOCWorksheetName As String
Dim NewTOCWorksheetName As String
Dim CurrentWorksheet As Worksheet
Dim Count As Integer
ProposedTOCWorksheetName = "TOC"
NewTOCWorksheetName = "TOC"
RowCounter = 2
Application.ScreenUpdating = False
Do While SheetExists(NewTOCWorksheetName)
NewTOCWorksheetName = Application.InputBox( _
Prompt:="A sheet named '" & ProposedTOCWorksheetName & "' already exists. " & _
"Enter a new sheet name or type '" & ProposedTOCWorksheetName & "' to overwrite.", _
Type:=2)
If NewTOCWorksheetName = ProposedTOCWorksheetName Then
Exit Do
End If
ProposedTOCWorksheetName = NewTOCWorksheetName
Loop
If SheetExists(NewTOCWorksheetName) Then
Sheets(NewTOCWorksheetName).Cells.Clear
Else
Sheets.Add Before:=Worksheets(1)
Worksheets(1).Name = NewTOCWorksheetName
End If
For Each CurrentWorksheet In Worksheets
If CurrentWorksheet.Name <> NewTOCWorksheetName Then
Sheets(NewTOCWorksheetName).Range("B" & RowCounter).Value = CurrentWorksheet.Name
Sheets(NewTOCWorksheetName).Hyperlinks.Add _
Anchor:=Sheets(NewTOCWorksheetName).Range("B" & RowCounter), _
Address:="", _
SubAddress:="'" & CurrentWorksheet.Name & "'!A1", _
TextToDisplay:=CurrentWorksheet.Name, _
ScreenTip:=CurrentWorksheet.Name
RowCounter = RowCounter + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Function SheetExists(SheetName As String) As Boolean
Dim TestWorksheet As Worksheet
SheetExists = False
On Error Resume Next
Set TestWorksheet = Sheets(SheetName)
If Not TestWorksheet Is Nothing Then SheetExists = True
Set TestWorksheet = Nothing
On Error GoTo 0
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment