Macro for an Advanced Index page with hyperlinks in excel

[Enviroseller]

Hi Guys,

I've been looking through some of the macros here but they don't seem to be as detailed as I need.

Here are the specs for the source answer sheet:

• Multiple Tabs,no set number of tabs (so we need a loop), Tab names will have spaces sometimes
• Fields with data in column A in every tab contain the title of each question (this is what we need to index and hyperlink)

What I am looking for in the index sheet:

• Colum A Should have the name of the Tabs (Does not need to be hyper linked)
• Column B should have the hyper linked Column A question titles that correspond to the Sheet name above them

i.e.

Sheet 1
Q1
Q2
Q3

Sheet 2
Q4
Q5
Q6

Can anybody help?

Thanks in advance!

 

[Enviroseller]

So far I found a great Macro but need to edit the loop that creates the hyper links to display the sheet name and the question names like my example.
Can anyone help me?

Option Explicit

Sub CreateINDEX()
'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 = 2 '<<== 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("INDEX").Activate
'Confirm the desire to overwrite sheet if it exists already.
If MsgBox("You already have a Table of Contents page." _
& vbLf & vbLf & _
"Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace INDEX 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("INDEX").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 INDEX sheet.
ActiveSheet.Name = "INDEX"
With Sheets("INDEX")
.Cells.Interior.ColorIndex = cShade
.Rows("4:65536").RowHeight = 16
.Range("A1").Value = "Envirosell Inc."
.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("INDEX")
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
.Range("B" & nRow).Value = nRow - 2
nRow = nRow + 1

End With

continueLoop:
Next i




'Perform some last minute formatting.
With Sheets("INDEX")
.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