I just added the code from the thread: http://www.computing.net/answers/of... to my workbook. It is working like a charm. I also created a separate macro that creates a button on the index sheet, that fires the CreateTOC-macro when clicked. Adding a line in the CreateTOC macro starts that macro, so now this button is also recreated when CreateTOC is refreshed.
Button-create macro:
Sub Button_on_IndexSheet() ActiveSheet.Buttons.Add(276, 20.25, 111, 26.25).Select ActiveSheet.Shapes("Button 1").Select Selection.Characters.Text = "renew index" With Selection.Characters(Start:=1, Length:=16).Font .Name = "Arial" .FontStyle = "Standard" .Size = 10 End With 'ActiveSheet.Shapes("Button 1").Select Selection.OnAction = "CreateTOC" Range("A1").Select End SubLine in "CreateTOC" macro (inserted before the comment: 'Turn events back on.):
Application.Run ("Button_on_IndexSheet")Hope this is usefull for some people.
I do have another question about this "CreateTOC" macro though.
My workbook now contains 25 sheets, but there will be many more very soon.
To prevent scrolling though the index once the number of sheets exceeds 25, I would like the macro to start a new set of columns (ID and Sheetname) after a given number of links have been created (lets say 25). And if the number of sheets exceeds 50 to begin a third set and so on. There should be a "blank" column in between each two sets.Does anyone know how to change the code so that it would do just that?
Thanks,Tijs
hi Here is a relatively inelegant way to add columns of 50 up to 4 columns with the last column taking everything remaining.
Sub CreateTOC2() '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, nCols As Integer '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 = 37 '<<== 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("TOC").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 TOC 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("TOC").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 TOC sheet. ActiveSheet.Name = "TOC" With Sheets("TOC") .Cells.Interior.ColorIndex = cShade .Rows("4:65536").RowHeight = 16 .Range("A1").Value = "Designed by VBAX" .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 nCols = Application.RoundUp(N / 50, 0) nRow = 4 For i = 2 To 51 If i < N + 2 Then With Sheets("TOC") 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 End If Next i If N > 50 Then nRow = 4 For i = 52 To 101 If i < N + 2 Then With Sheets("TOC") shtName = Sheets(i).Name 'Add a hyperlink to A1 of each sheet. .Range("F" & nRow).Hyperlinks.Add _ Anchor:=.Range("F" & nRow), Address:="#'" & _ shtName & "'!A1", TextToDisplay:=shtName .Range("F" & nRow).HorizontalAlignment = xlLeft .Range("E" & nRow).Value = nRow + 48 nRow = nRow + 1 End With End If Next i End If If N > 100 Then nRow = 4 For i = 102 To 151 If i < N + 2 Then With Sheets("TOC") shtName = Sheets(i).Name 'Add a hyperlink to A1 of each sheet. .Range("I" & nRow).Hyperlinks.Add _ Anchor:=.Range("I" & nRow), Address:="#'" & _ shtName & "'!A1", TextToDisplay:=shtName .Range("I" & nRow).HorizontalAlignment = xlLeft .Range("H" & nRow).Value = nRow + 98 nRow = nRow + 1 End With End If 'continueLoop: Next i End If If N > 150 Then nRow = 4 For i = 152 To N If i < N + 2 Then With Sheets("TOC") shtName = Sheets(i).Name 'Add a hyperlink to A1 of each sheet. .Range("L" & nRow).Hyperlinks.Add _ Anchor:=.Range("L" & nRow), Address:="#'" & _ shtName & "'!A1", TextToDisplay:=shtName .Range("L" & nRow).HorizontalAlignment = xlLeft .Range("K" & nRow).Value = nRow + 148 nRow = nRow + 1 End With End If Next i End If 'Perform some last minute formatting. With Sheets("TOC") .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
