Solved: Macro within a Macro

Echognome · 17-May-2007, 02:10 PM #1

Hi,

New to the forum, but reasonably experienced on Excel.

I'm trying to create a macro that will generate a table of contents worksheet that can navigate to any worksheet in your workbook and also be able to jump back to the table of contents page. I know we have the navigation tabs at the bottom, but when you're dealing with spreadsheets of 50+ sheets, it's nice to be able to navigate quickly. I also believe that button navigation looks a lot nicer than hyperlink navigation.

Anyway, here is what I've figured out thus far:

Code:

Option Explicit
Sub TableOfContents()
    Dim item As Worksheet
    Dim SheetCount As Integer
    Dim i As Integer: i = 0
    Dim SheetName As String
    Dim NameArray() As String
    Sheets(1).Select
    Sheets.Add
    Sheets(1).Select
    ActiveSheet.Name = "Table of Contents"
    SheetCount = ActiveWorkbook.Worksheets.Count
    ReDim NameArray(1 To SheetCount)
    For Each item In ActiveWorkbook.Worksheets
        i = i + 1
        Sheets(i).Select
        NameArray(i) = ActiveSheet.Name
        If i > 1 Then
            ActiveSheet.Buttons.Add(213, 10.5, 75.75, 30).Select
            Selection.OnAction = "Home"
            Selection.Characters.Text = "Home"
            With Selection.Characters(Start:=1, Length:=4).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 10
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
        End If
        Range("A1").Select
        Sheets("Table of Contents").Select
    Next item
    Sheets("Table of Contents").Select
End Sub

Sub home()
    Sheets("Table of Contents").Select
End Sub

This adds the Table of Contents worksheet and a button on each sheet other than the Table of Contents worksheet to navigate back to that sheet. That part is working just fine.

Now, the difficulty I'm having is creating buttons on the Table of Contents sheet for each worksheet. What I'd like to have is a button with the name of the worksheet as it's title (I've figured out how to do that part), but also for a macro to be created (like home()) for each sheet and have it navigate to that sheet. I mean the code for navigation is exceedingly simple, but I can't figure out how to have a macro generate other macros and also how to get it to assign a macro to the button with the name of worksheet as the macro.

I'm certainly open to other suggestions and appreciate any help you can provide.

Thanks in advance,

Matt

Echognome · 17-May-2007, 02:12 PM #2

I don't know why it cut off part of my code, but the rest of it reads:

Code:

        End If
        Range("A1").Select
        Sheets("Table of Contents").Select
    Next item
    Sheets("Table of Contents").Select
End Sub

Sub home()
    Sheets("Table of Contents").Select
End Sub

Zack Barresse · 17-May-2007, 03:48 PM #3

Hi there,

Here is some code I wrote a little while back. I've made some slight adjustments, should work for most situations...

Code:

Option Explicit

Sub Test()
    Call CreateTOC(ActiveWorkbook)
End Sub

Sub CreateTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String
    Dim nRow As Long, i As Long, N 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    '-------------------------------------------------------------------------------
    cShade = 37    '<<== SET BACKGROUND COLOR DESIRED HERE
    '-------------------------------------------------------------------------------
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    wkb.Sheets(TOCname).Delete
    wkb.Sheets.Add before:=Sheets(1)
    wkb.Sheets(1).Name = TOCname
    On Error GoTo 0
    With wkb.Sheets(TOCname)
        .Cells.Interior.ColorIndex = cShade
        .Rows("4:" & .Rows.Count).RowHeight = 16
        .Range("A2").Value = "Table of Contents"
        .Range("A2").Font.Bold = True
        .Range("A2").Font.Name = "Arial"
        .Range("A2").Font.Size = "24"
    End With
    For i = 2 To wkb.Sheets.Count
        With wkb.Sheets(TOCname)
            'Check if sheet is a chart sheet.
            If IsChart(wkb.Sheets(i).Name, wkb) Then
                '** Sheet IS a Chart Sheet
                cCnt = cCnt + 1
                shtName = wkb.Charts(cCnt).Name
                .Range("C" & nRow).Value = shtName
                .Range("C" & nRow).Font.ColorIndex = cShade
                'Set variables for button dimensions.
                cLeft = .Range("C" & nRow).Left
                cTop = .Range("C" & nRow).Top
                cWidth = .Range("C" & nRow).Width
                cHeight = .Range("C" & nRow).RowHeight
                cAddy = "R" & nRow & "C3"
                'Add button to cell dimensions.
                Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
                                          cLeft, cTop, cWidth, cHeight)
                cb.Select
                'Use older technique to add Chart sheet name to button text.
                ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
                'Format shape to look like hyperlink and match background color (transparent).
                With Selection
                    .ShapeRange.Fill.ForeColor.SchemeColor = 0
                    With .Font
                        .Underline = xlUnderlineStyleSingle
                        .ColorIndex = 5
                    End With
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
'                    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignJustify
                    .OnAction = "Mod_Main.GotoChart"
                End With
            Else
                '** Sheet is NOT a Chart sheet.
                shtName = wkb.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
            End If
            .Range("B" & nRow).Value = nRow - 3
            nRow = nRow + 1
        End With
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").EntireColumn.ColumnWidth = 25
        .Range("C:C").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState = True Then
            .CutCopyMode = False
            .StatusBar = False
        End If
    End With
End Sub

Edit: In fact, here is the original: http://vbaexpress.com/kb/getarticle.php?kb_id=120. The code posted here is updated (I have to update the KB entry still).

HTH

Echognome · 17-May-2007, 05:12 PM #4

Thank you very much for your help. I do have a couple of follow-up questions if you don't mind.

First, I copied and ran your macro and if I have a chart sheet as one of my worksheets, the Chart link is always positioned on the left-side of the Cell (despite having center alignment), whereas the other worksheets are center-aligned.

Second, although the hyperlinks for ordinary worksheets works fine, when I click on a Chart link, it returns "The macro 'Book1!Mod_Main.GotoChart!' cannot be found." I see that you've written a GotoChart macro, but for some reason it doesn't like the path.

Finally, although I appreciate the nice ease of using hyperlinks, is it not possible to create buttons? If the answer is "Yes, but it will take an extraordinary amount of extra coding," then I certainly understand it's not worth doing it.

Either way, I have a fairly workable solution now. I can obviously modify the design and look of the Table of Contents page myself. Thanks so much for your time.

-Matt

Zack Barresse · 17-May-2007, 08:33 PM #5

Hi there,

The module where you copied the code must be named "Mod_Main", or you can change that name in the line of code where you find it.

Basically, it does create a button for the chart sheets and assigns a macro to it. The macro is the GoToChart routine. The buttons are just see-through so it just looks like there is no button there making it more seamless.

If you do not want the data center aligned then change this line..

Code:

        .Range("C:C").HorizontalAlignment = xlCenter

.. to this ..

Code:

        .Range("C:C").HorizontalAlignment = xlLeft

Should do it.

Stephen Bullen also had a similar solution. This took into account Chart sheets as well. I coded mine before I knew he had one, so I kind of reinvented the wheel. His is slightly different than mine, but it's basically the same methodology.

HTH

Echognome · 17-May-2007, 09:40 PM #6

Thanks. After some stylistic adjustments I made, it looks great and impressed all of the managers. Thanks so much for your help.

Matt

Zack Barresse · 18-May-2007, 12:26 AM #7

Great!

Oh, and btw (sorry, I forgot my manners), welcome to the board!!

Echognome · 23-May-2007, 02:52 PM #8

I just wanted to add a follow up to this. I found out the hard way that if the workbook you use has any hidden worksheets, then the macro will return an error at the point you try to select the worksheet. I thought about what I wanted to do with this and figured that if someone hid a worksheet, the reason must be that they do not want the worksheet seen. So I included a few lines of code with an "If wkb.Sheets(i).Visible = True Then" blah blah blah. That way it skipped over any hidden worksheets. Just thought I'd add that in case anyone else wanted to use the code.

Zack Barresse · 24-May-2007, 06:26 PM #9

Cool beans. Thanks! Would you mind posting your full code used?

Echognome · 24-May-2007, 07:06 PM **#10**

Absolutely! However, I was waiting until I resolved the linking back to the Table of Contents page. In the meantime I will post my full code for when the buttons are in use.

There are still two bugs floating about and maybe someone will want to take a crack at them.

1) When there is a chart sheet, the text on the invisible rectangle (that acts as a hyperlink) is slightly askew from the text in the cell on the Table of Contents page. I'm not sure why this is.

2) When there is a hidden worksheet, it still counts it as a sheet when listing the sheet number (to see this best, try putting a hidden worksheet somewhere in the middle of the workbook). These are fairly easy to rectify after you run the macro, but it would be nice if it weren't a problem to begin with.

I will try to address these bugs, but I have to say that at the moment, it's not a high priority.

Anyway, the code will follow shortly.

Matt

Echognome · 24-May-2007, 07:15 PM **#11**

Code:

Option Explicit


Sub TableContents()
'
' TableContents Macro
' Generates a Table of Contents
'
    Call CreateTOC(ActiveWorkbook)
End Sub

Sub CreateTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String, shtColor As Integer
    Dim nRow As Long, i As Long, N 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    '-------------------------------------------------------------------------------
    cShade = 22    '<<== SET BACKGROUND COLOR DESIRED HERE
    '-------------------------------------------------------------------------------
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    'Delete Table of Contents sheet if it already exists. (alternate code might be to end sub)
    wkb.Sheets(TOCname).Delete
    wkb.Sheets.Add before:=Sheets(1)
    wkb.Sheets(1).Name = TOCname
    'Look at 2nd sheet to see if colors are being used for sheet tabs.
    If wkb.Sheets(2).Tab.ColorIndex <> -4142 Then
       wkb.Sheets(1).Tab.ColorIndex = 24
    Else: End If
    On Error GoTo 0
    'Add some basic formatting to Table of Contents worksheet
    With wkb.Sheets(TOCname)
        .Cells.Interior.ColorIndex = cShade
        .Rows("4:" & .Rows.Count).RowHeight = 16
        .Range("A2").Value = "Table of Contents"
        .Range("A2").Font.Bold = True
        .Range("A2").Font.Name = "Arial"
        .Range("A2").Font.Size = "24"
        .Range("B3").Value = "Sheet #"
        .Range("C3").Value = "Sheet Title"
    End With
    For i = 1 To wkb.Sheets.Count
        With wkb.Sheets(TOCname)
            'Check if sheet is a chart sheet.
            If IsChart(wkb.Sheets(i).Name, wkb) Then
                '** Sheet IS a Chart Sheet
                cCnt = cCnt + 1
                shtColor = wkb.Sheets(i).Tab.ColorIndex
                shtName = wkb.Charts(cCnt).Name
                .Range("C" & nRow).Value = shtName
                .Range("C" & nRow).Interior.ColorIndex = shtColor
                'Set variables for button dimensions.
                cLeft = .Range("C" & nRow).Left
                cTop = .Range("C" & nRow).Top
                cWidth = .Range("C" & nRow).Width
                cHeight = .Range("C" & nRow).RowHeight
                cAddy = "R" & nRow & "C3"
                'Add button to cell dimensions.
                Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
                                          cLeft, cTop, cWidth, cHeight)
                cb.Select
                'Use older technique to add Chart sheet name to button text.
                ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
                'Format shape to look like hyperlink and match background color (transparent).
                With Selection
                    .ShapeRange.Fill.ForeColor.SchemeColor = 0
                    With .Font
                        .Underline = xlUnderlineStyleSingle
                        .ColorIndex = 5
                    End With
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
'                    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignJustify
                    .OnAction = "Module1.GotoChart"
                End With
            ElseIf wkb.Sheets(i).Visible = True Then
                '** Sheet is NOT a Chart sheet.
                shtColor = wkb.Sheets(i).Tab.ColorIndex
                shtName = wkb.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("C" & nRow).Interior.ColorIndex = shtColor
            End If
            .Range("B" & nRow).Value = nRow - 3
            .Range("B" & nRow).Interior.ColorIndex = shtColor
            nRow = nRow + 1
        End With
        If i > 1 Then
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                'Alternative method of creating a button that hyperlinks back to the TOC page.
'                ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0#, 0#, 85, 12.75).Select
'                Selection.ShapeRange.Fill.Solid
'                Selection.ShapeRange.Line.Weight = 0.75
'                Selection.ShapeRange.Line.DashStyle = msoLineSolid
'                Selection.ShapeRange.Line.Style = msoLineSingle
'                ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="#'" & TOCname & "'!A1"
'                Selection.Characters.Text = TOCname
                ActiveSheet.Buttons.Add(0, 0, 100, 15).Select
                Selection.OnAction = "Home"
                Selection.Characters.Text = "Table of Contents"
                With Selection.Characters(Start:=1, Length:=4).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 10
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                   .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
            End If
        End If
        If IsChart(wkb.Sheets(i).Name, wkb) Then
        wkb.Sheets(i).ChartArea.Select
        ElseIf wkb.Sheets(i).Visible = True Then
        wkb.Sheets(i).Range("A1").Select
        End If
        wkb.Sheets(TOCname).Select
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").Columns.AutoFit
        .Range("C:C").HorizontalAlignment = xlLeft
        .Range("B:B").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    ActiveWindow.DisplayGridlines = False
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState = True Then
            .CutCopyMode = False
            .StatusBar = False
        End If
    End With
    Application.OnUndo "The Last Macro", "UndoTOC"
End Sub
Sub home()
    Sheets("Table of Contents").Select
End Sub
Sub UndoTableOfContents()
    Call UndoTOC(ActiveWorkbook)
End Sub

Sub UndoTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String, shtColor As Integer
    Dim nRow As Long, i As Long, j As Integer, N As Long, tmpCount As Long
    Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String, tmpname 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    'Deletes the Table of Contents Worksheet
    wkb.Sheets(TOCname).Delete
    On Error GoTo 0
    For i = 1 To wkb.Sheets.Count
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                If ActiveSheet.Shapes.Count > 0 Then
                    For j = 1 To ActiveSheet.Shapes.Count
                    ActiveSheet.Shapes(j).Select
                    On Error Resume Next
                    If Selection.Characters.Text = TOCname Then
                        Selection.Delete
                        ActiveSheet.Buttons(j + 1).Select
                        On Error Resume Next
                    End If
                    Next j
                End If
            End If
            'ActiveSheet.objects("Table of Contents").Delete
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
    Call ToggleEvents(True)
End Sub

Echognome · 24-May-2007, 07:16 PM **#12**

Code:

    wkb.Sheets(TOCname).Delete
    wkb.Sheets.Add before:=Sheets(1)
    wkb.Sheets(1).Name = TOCname
    'Look at 2nd sheet to see if colors are being used for sheet tabs.
    If wkb.Sheets(2).Tab.ColorIndex <> -4142 Then
       wkb.Sheets(1).Tab.ColorIndex = 24
    Else: End If
    On Error GoTo 0
    'Add some basic formatting to Table of Contents worksheet
    With wkb.Sheets(TOCname)
        .Cells.Interior.ColorIndex = cShade
        .Rows("4:" & .Rows.Count).RowHeight = 16
        .Range("A2").Value = "Table of Contents"
        .Range("A2").Font.Bold = True
        .Range("A2").Font.Name = "Arial"
        .Range("A2").Font.Size = "24"
        .Range("B3").Value = "Sheet #"
        .Range("C3").Value = "Sheet Title"
    End With
    For i = 1 To wkb.Sheets.Count
        With wkb.Sheets(TOCname)
            'Check if sheet is a chart sheet.
            If IsChart(wkb.Sheets(i).Name, wkb) Then
                '** Sheet IS a Chart Sheet
                cCnt = cCnt + 1
                shtColor = wkb.Sheets(i).Tab.ColorIndex
                shtName = wkb.Charts(cCnt).Name
                .Range("C" & nRow).Value = shtName
                .Range("C" & nRow).Interior.ColorIndex = shtColor
                'Set variables for button dimensions.
                cLeft = .Range("C" & nRow).Left
                cTop = .Range("C" & nRow).Top
                cWidth = .Range("C" & nRow).Width
                cHeight = .Range("C" & nRow).RowHeight
                cAddy = "R" & nRow & "C3"
                'Add button to cell dimensions.
                Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
                                          cLeft, cTop, cWidth, cHeight)
                cb.Select
                'Use older technique to add Chart sheet name to button text.
                ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
                'Format shape to look like hyperlink and match background color (transparent).
                With Selection
                    .ShapeRange.Fill.ForeColor.SchemeColor = 0
                    With .Font
                        .Underline = xlUnderlineStyleSingle
                        .ColorIndex = 5
                    End With
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
'                    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignJustify
                    .OnAction = "Module1.GotoChart"
                End With
            ElseIf wkb.Sheets(i).Visible = True Then
                '** Sheet is NOT a Chart sheet.
                shtColor = wkb.Sheets(i).Tab.ColorIndex
                shtName = wkb.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("C" & nRow).Interior.ColorIndex = shtColor
            End If
            .Range("B" & nRow).Value = nRow - 3
            .Range("B" & nRow).Interior.ColorIndex = shtColor
            nRow = nRow + 1
        End With
        If i > 1 Then
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                'Alternative method of creating a button that hyperlinks back to the TOC page.
'                ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0#, 0#, 85, 12.75).Select
'                Selection.ShapeRange.Fill.Solid
'                Selection.ShapeRange.Line.Weight = 0.75
'                Selection.ShapeRange.Line.DashStyle = msoLineSolid
'                Selection.ShapeRange.Line.Style = msoLineSingle
'                ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="#'" & TOCname & "'!A1"
'                Selection.Characters.Text = TOCname
                ActiveSheet.Buttons.Add(0, 0, 100, 15).Select
                Selection.OnAction = "Home"
                Selection.Characters.Text = "Table of Contents"
                With Selection.Characters(Start:=1, Length:=4).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 10
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                   .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
            End If
        End If
        If IsChart(wkb.Sheets(i).Name, wkb) Then
        wkb.Sheets(i).ChartArea.Select
        ElseIf wkb.Sheets(i).Visible = True Then
        wkb.Sheets(i).Range("A1").Select
        End If
        wkb.Sheets(TOCname).Select
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").Columns.AutoFit
        .Range("C:C").HorizontalAlignment = xlLeft
        .Range("B:B").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    ActiveWindow.DisplayGridlines = False
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState = True Then
            .CutCopyMode = False
            .StatusBar = False
        End If
    End With
    Application.OnUndo "The Last Macro", "UndoTOC"
End Sub
Sub home()
    Sheets("Table of Contents").Select
End Sub
Sub UndoTableOfContents()
    Call UndoTOC(ActiveWorkbook)
End Sub

Sub UndoTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String, shtColor As Integer
    Dim nRow As Long, i As Long, j As Integer, N As Long, tmpCount As Long
    Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String, tmpname 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    'Deletes the Table of Contents Worksheet
    wkb.Sheets(TOCname).Delete
    On Error GoTo 0
    For i = 1 To wkb.Sheets.Count
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                If ActiveSheet.Shapes.Count > 0 Then
                    For j = 1 To ActiveSheet.Shapes.Count
                    ActiveSheet.Shapes(j).Select
                    On Error Resume Next
                    If Selection.Characters.Text = TOCname Then
                        Selection.Delete
                        ActiveSheet.Buttons(j + 1).Select
                        On Error Resume Next
                    End If
                    Next j
                End If
            End If
            'ActiveSheet.objects("Table of Contents").Delete
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
    Call ToggleEvents(True)
End Sub

Echognome · 24-May-2007, 07:17 PM **#13**

Code:

                cHeight = .Range("C" & nRow).RowHeight
                cAddy = "R" & nRow & "C3"
                'Add button to cell dimensions.
                Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
                                          cLeft, cTop, cWidth, cHeight)
                cb.Select
                'Use older technique to add Chart sheet name to button text.
                ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
                'Format shape to look like hyperlink and match background color (transparent).
                With Selection
                    .ShapeRange.Fill.ForeColor.SchemeColor = 0
                    With .Font
                        .Underline = xlUnderlineStyleSingle
                        .ColorIndex = 5
                    End With
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
'                    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignJustify
                    .OnAction = "Module1.GotoChart"
                End With
            ElseIf wkb.Sheets(i).Visible = True Then
                '** Sheet is NOT a Chart sheet.
                shtColor = wkb.Sheets(i).Tab.ColorIndex
                shtName = wkb.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("C" & nRow).Interior.ColorIndex = shtColor
            End If
            .Range("B" & nRow).Value = nRow - 3
            .Range("B" & nRow).Interior.ColorIndex = shtColor
            nRow = nRow + 1
        End With
        If i > 1 Then
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                'Alternative method of creating a button that hyperlinks back to the TOC page.
'                ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0#, 0#, 85, 12.75).Select
'                Selection.ShapeRange.Fill.Solid
'                Selection.ShapeRange.Line.Weight = 0.75
'                Selection.ShapeRange.Line.DashStyle = msoLineSolid
'                Selection.ShapeRange.Line.Style = msoLineSingle
'                ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="#'" & TOCname & "'!A1"
'                Selection.Characters.Text = TOCname
                ActiveSheet.Buttons.Add(0, 0, 100, 15).Select
                Selection.OnAction = "Home"
                Selection.Characters.Text = "Table of Contents"
                With Selection.Characters(Start:=1, Length:=4).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 10
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                   .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
            End If
        End If
        If IsChart(wkb.Sheets(i).Name, wkb) Then
        wkb.Sheets(i).ChartArea.Select
        ElseIf wkb.Sheets(i).Visible = True Then
        wkb.Sheets(i).Range("A1").Select
        End If
        wkb.Sheets(TOCname).Select
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").Columns.AutoFit
        .Range("C:C").HorizontalAlignment = xlLeft
        .Range("B:B").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    ActiveWindow.DisplayGridlines = False
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState = True Then
            .CutCopyMode = False
            .StatusBar = False
        End If
    End With
    Application.OnUndo "The Last Macro", "UndoTOC"
End Sub
Sub home()
    Sheets("Table of Contents").Select
End Sub
Sub UndoTableOfContents()
    Call UndoTOC(ActiveWorkbook)
End Sub

Sub UndoTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String, shtColor As Integer
    Dim nRow As Long, i As Long, j As Integer, N As Long, tmpCount As Long
    Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String, tmpname 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    'Deletes the Table of Contents Worksheet
    wkb.Sheets(TOCname).Delete
    On Error GoTo 0
    For i = 1 To wkb.Sheets.Count
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                If ActiveSheet.Shapes.Count > 0 Then
                    For j = 1 To ActiveSheet.Shapes.Count
                    ActiveSheet.Shapes(j).Select
                    On Error Resume Next
                    If Selection.Characters.Text = TOCname Then
                        Selection.Delete
                        ActiveSheet.Buttons(j + 1).Select
                        On Error Resume Next
                    End If
                    Next j
                End If
            End If
            'ActiveSheet.objects("Table of Contents").Delete
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
    Call ToggleEvents(True)
End Sub

Echognome · 24-May-2007, 07:17 PM **#14**

Code:

            End If
            .Range("B" & nRow).Value = nRow - 3
            .Range("B" & nRow).Interior.ColorIndex = shtColor
            nRow = nRow + 1
        End With
        If i > 1 Then
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                'Alternative method of creating a button that hyperlinks back to the TOC page.
'                ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0#, 0#, 85, 12.75).Select
'                Selection.ShapeRange.Fill.Solid
'                Selection.ShapeRange.Line.Weight = 0.75
'                Selection.ShapeRange.Line.DashStyle = msoLineSolid
'                Selection.ShapeRange.Line.Style = msoLineSingle
'                ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="#'" & TOCname & "'!A1"
'                Selection.Characters.Text = TOCname
                ActiveSheet.Buttons.Add(0, 0, 100, 15).Select
                Selection.OnAction = "Home"
                Selection.Characters.Text = "Table of Contents"
                With Selection.Characters(Start:=1, Length:=4).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 10
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                   .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
            End If
        End If
        If IsChart(wkb.Sheets(i).Name, wkb) Then
        wkb.Sheets(i).ChartArea.Select
        ElseIf wkb.Sheets(i).Visible = True Then
        wkb.Sheets(i).Range("A1").Select
        End If
        wkb.Sheets(TOCname).Select
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").Columns.AutoFit
        .Range("C:C").HorizontalAlignment = xlLeft
        .Range("B:B").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    ActiveWindow.DisplayGridlines = False
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState = True Then
            .CutCopyMode = False
            .StatusBar = False
        End If
    End With
    Application.OnUndo "The Last Macro", "UndoTOC"
End Sub
Sub home()
    Sheets("Table of Contents").Select
End Sub
Sub UndoTableOfContents()
    Call UndoTOC(ActiveWorkbook)
End Sub

Sub UndoTOC(Optional wkb As Workbook, Optional TOCname As String = "Table of Contents")
'Declare all variables
    Dim ws As Worksheet, curws As Worksheet, shtName As String, shtColor As Integer
    Dim nRow As Long, i As Long, j As Integer, N As Long, tmpCount As Long
    Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String, tmpname 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 wkb Is Nothing Then
        If ActiveWorkbook Is Nothing Then
            MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
            Exit Sub
        Else
            Set wkb = ActiveWorkbook
        End If
    End If
    Call ToggleEvents(False)
    nRow = 4
    On Error Resume Next
    'Deletes the Table of Contents Worksheet
    wkb.Sheets(TOCname).Delete
    On Error GoTo 0
    For i = 1 To wkb.Sheets.Count
            If wkb.Sheets(i).Visible = True Then
                wkb.Sheets(i).Select
                If ActiveSheet.Shapes.Count > 0 Then
                    For j = 1 To ActiveSheet.Shapes.Count
                    ActiveSheet.Shapes(j).Select
                    On Error Resume Next
                    If Selection.Characters.Text = TOCname Then
                        Selection.Delete
                        ActiveSheet.Buttons(j + 1).Select
                        On Error Resume Next
                    End If
                    Next j
                End If
            End If
            'ActiveSheet.objects("Table of Contents").Delete
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
    Call ToggleEvents(True)
End Sub

Echognome · 24-May-2007, 07:18 PM **#15**

Code:

       If IsChart(wkb.Sheets(i).Name, wkb) Then
        wkb.Sheets(i).ChartArea.Select
        ElseIf wkb.Sheets(i).Visible = True Then
        wkb.Sheets(i).Range("A1").Select
        End If
        wkb.Sheets(TOCname).Select
continueLoop:
    Next i
    'Perform some last minute formatting.
    With wkb.Sheets(TOCname)
        .Range("C:C").Columns.AutoFit
        .Range("C:C").HorizontalAlignment = xlLeft
        .Range("B:B").HorizontalAlignment = xlCenter
        .Range("A4").Activate
    End With
    ActiveWindow.DisplayGridlines = False
    strMsg = vbNewLine & vbNewLine & "Please note: " & _
             "Charts will have hyperlinks associated with an object."
    'Toggle message box for chart existence or not, information only.
    If wkb.Charts.Count = 0 Then strMsg = ""
ExitHere:
    Call ToggleEvents(True)
End Sub

Public Function IsChart(cName As String, wkbC As Workbook) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
    Dim tmpChart As Chart
    On Error Resume Next
    'If not a chart, this line will error out.
    Set tmpChart = wkbC.Charts(cName)
    'Function will be determined if the variable is now an Object or not.
    IsChart = IIf(tmpChart Is Nothing, False, True)
End Function

Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
    Dim obj As Object, objName As String
    On Error GoTo NoChart
    'With the button text as the Chart name, we use the Caller method to obtain it.
    Set obj = ActiveSheet.Shapes(Application.Caller)
    'The latter portion of the AlternativeText will give us the exact Chart name.
    objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
                                              InStr(1, obj.AlternativeText, ": ")))
    'Then we can perform a standard Chart sheet Activate method using the variable.
    Charts(objName).Activate
    'Optional: zoom Chart sheet to fit screen.
    'Depending on screen resolution, this may need adjustment(s).
    ActiveWindow.Zoom = 80
NoChart:
    MsgBox "There was a problem activating that chart!", vbExclamation, "ERROR!"
End Sub

Tag Cloud
access acer asus bios bsod crash desktop driver drivers error ethernet excel freeze games gaming hard drive hardware hdmi internet laptop malware memory missing monitor motherboard network printer problem ram random registry router slow software sound trojan ubuntu 11.10 uninstall usb video virus vista wifi windows windows 7 windows 7 32 bit windows 7 64 bit windows xp wireless xbox

Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)

Search
Search for:

Find the solution to yourcomputer problem!

Find the solution to your
computer problem!