jt_codeless
03-29-2016, 11:21 PM
Hi,
I'm using a variation of Zack Baresse's Table of Contents code. I'm trying to incorporate some code that will create hyperlinks to the folders that the tabs reference during the creation of the ToC. I would like them created 5 columns to the right of the contents list under the "Folder Links" (as below).
The interesting bit is that there is a base folder that will form part of the address (this isn't constant for every workbook). Effectively I would like to make a macro that creates hyperlinks rather than needing to run the hyperlink function over and over.
The function I'd like to make a macro for is =hyperlink($c$3&H4&"\","LINK")
Below is the template of what I'm working with. I'd like the hyperlinks to be created where "Link" is written. The Base folder is "C:\Users\Your.Name\Documents\Base_Folder" or ($C$3), I'd like the macro to continue until the end of the contents list.
15774
Here is Zack's ToC Cod
Sub CreateTOC()
' Code by Zack Baresse
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim ws As Worksheet, _
ct As Chart, _
shtName As String, _
nrow As Long, _
tmpCount As Long, _
i As Long, _
numCharts As Long
nrow = 3
i = 1
numCharts = ActiveWorkbook.Charts.Count
On Error GoTo hasSheet
Sheets("Table of Contents").Activate
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:
Sheets.Add Before:=Sheets(1)
GoTo hasNew
createNew:
Sheets("Table of Contents").Delete
GoTo hasSheet
hasNew:
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
ActiveSheet.Name = "Table of Contents"
With Sheets("Table of Contents")
'.Cells.Interior.ColorIndex = 4
With .Range("B2")
.Value = "Table of Contents"
.Font.Bold = True
.Font.Name = "Calibri"
.Font.Size = "24"
End With
End With
For Each ws In ActiveWorkbook.Worksheets
nrow = nrow + 1
With ws
shtName = ws.Name
With Sheets("Table of Contents")
.Range("B" & nrow).Value = nrow - 3
.Range("C" & nrow).Hyperlinks.Add _
Anchor:=Sheets("Table of Contents").Range("C" & nrow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range("C" & nrow).HorizontalAlignment = xlLeft
End With
End With
Next ws
If numCharts <> 0 Then
For Each ct In ActiveWorkbook.Charts
nrow = nrow + 1
shtName = ct.Name
With Sheets("Table of Contents")
.Range("B" & nrow).Value = nrow - 3
.Range("C" & nrow).Value = shtName
.Range("C" & nrow).HorizontalAlignment = xlLeft
End With
Next ct
End If
With Sheets("Table of Contents")
With .Range("B2:G2")
.MergeCells = True
.HorizontalAlignment = xlLeft
End With
With .Range("C:C")
.EntireColumn.AutoFit
.Activate
End With
.Range("B4").Select
End With
.DisplayAlerts = True
.ScreenUpdating = True
End With
MsgBox "Done!" & vbNewLine & vbNewLine & "Please note: " & _
"Charts are listed after regular " & vbCrLf & _
"worksheets and will not have hyperlinks.", vbInformation, "Complete!"
End Sub
Particulars: Excel 2010, Win 7 Pro
I'm using a variation of Zack Baresse's Table of Contents code. I'm trying to incorporate some code that will create hyperlinks to the folders that the tabs reference during the creation of the ToC. I would like them created 5 columns to the right of the contents list under the "Folder Links" (as below).
The interesting bit is that there is a base folder that will form part of the address (this isn't constant for every workbook). Effectively I would like to make a macro that creates hyperlinks rather than needing to run the hyperlink function over and over.
The function I'd like to make a macro for is =hyperlink($c$3&H4&"\","LINK")
Below is the template of what I'm working with. I'd like the hyperlinks to be created where "Link" is written. The Base folder is "C:\Users\Your.Name\Documents\Base_Folder" or ($C$3), I'd like the macro to continue until the end of the contents list.
15774
Here is Zack's ToC Cod
Sub CreateTOC()
' Code by Zack Baresse
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim ws As Worksheet, _
ct As Chart, _
shtName As String, _
nrow As Long, _
tmpCount As Long, _
i As Long, _
numCharts As Long
nrow = 3
i = 1
numCharts = ActiveWorkbook.Charts.Count
On Error GoTo hasSheet
Sheets("Table of Contents").Activate
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:
Sheets.Add Before:=Sheets(1)
GoTo hasNew
createNew:
Sheets("Table of Contents").Delete
GoTo hasSheet
hasNew:
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
ActiveSheet.Name = "Table of Contents"
With Sheets("Table of Contents")
'.Cells.Interior.ColorIndex = 4
With .Range("B2")
.Value = "Table of Contents"
.Font.Bold = True
.Font.Name = "Calibri"
.Font.Size = "24"
End With
End With
For Each ws In ActiveWorkbook.Worksheets
nrow = nrow + 1
With ws
shtName = ws.Name
With Sheets("Table of Contents")
.Range("B" & nrow).Value = nrow - 3
.Range("C" & nrow).Hyperlinks.Add _
Anchor:=Sheets("Table of Contents").Range("C" & nrow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range("C" & nrow).HorizontalAlignment = xlLeft
End With
End With
Next ws
If numCharts <> 0 Then
For Each ct In ActiveWorkbook.Charts
nrow = nrow + 1
shtName = ct.Name
With Sheets("Table of Contents")
.Range("B" & nrow).Value = nrow - 3
.Range("C" & nrow).Value = shtName
.Range("C" & nrow).HorizontalAlignment = xlLeft
End With
Next ct
End If
With Sheets("Table of Contents")
With .Range("B2:G2")
.MergeCells = True
.HorizontalAlignment = xlLeft
End With
With .Range("C:C")
.EntireColumn.AutoFit
.Activate
End With
.Range("B4").Select
End With
.DisplayAlerts = True
.ScreenUpdating = True
End With
MsgBox "Done!" & vbNewLine & vbNewLine & "Please note: " & _
"Charts are listed after regular " & vbCrLf & _
"worksheets and will not have hyperlinks.", vbInformation, "Complete!"
End Sub
Particulars: Excel 2010, Win 7 Pro