VBA Excel Macro for Index Page in Excel RRS feed

  • Question

  • 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


    Sheet 1

    Sheet 2

    So far I found a great Macro but need to edit the loop that creates the hyper links to display the sheet name and hyperlink the question names instead of the sheet name like in 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
    '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
    '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
    x = 1
    'Add sheet as the first sheet in the workbook.
    Sheets.Add before:=Sheets(1)
    GoTo hasNew
    GoTo hasSheet
    '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"
    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

    Next i

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

    Friday, May 17, 2013 5:59 PM