Table of Contents: Hyperlinking to Folders Using a Combination of Cells

[jt_codeless]

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.

Excel_VBA_TOC_Q.jpg


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

[snb]

1. The code you showed refers to hyperlinks to sheets not to folders

2. can you please use Code Tags ?

3. an inventory of 'sub'folders:

Sub M_snb()
  for each it in createobject("scripting.filesystemobject").getfolder("G:\OF").folders

  next
End sub