Articles

Solved Make sheet index multi column in excel 2007

January 7, 2013 at 03:04:03
Specs: Windows 7

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 Sub

Line 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


See More: Make sheet index multi column in excel 2007

Report •


#1
January 7, 2013 at 17:29:14
✔ Best Answer

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


Report •
Related Solutions


Ask Question