Solved: Macro within a Macro - Page 2

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

Code:

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:20 PM **#17**

Code:

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 · 29-May-2007, 01:51 PM **#18**

I also solved a small problem of hidden worksheets creating an additional line in the table of contents page. After you include all of the if's for sheets.visible = true, you need to have one line at the bottom that says what to do if the sheet is hidden. All you have to add is Else If: nRow = nRow - 1.

Last problem is to figure out why the chart sheet button invisible buttons end up off by a little. My instinct is that this happens because the columns are auto-formatted for width after the button is created. So my guess is that the loop to add the layers of invisible hyperlinks needs to be done after the column widths are adjusted. Will work on it.

Zack Barresse · 30-May-2007, 03:26 PM **#19**

Try this code...

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
                .Range("C" & nRow).Font.ColorIndex = 5
                .Range("C" & nRow).Font.Underline = 2
                '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 = "Module2.GotoChart"
                End With
                .Range("B" & nRow).Value = nRow - 3
                .Range("B" & nRow).Interior.ColorIndex = shtColor
                nRow = nRow + 1
            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("C4", .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
        .Range(.Cells(.Rows.Count, 3).End(xlUp).Offset(1, -1), _
               .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)).Delete shift:=xlUp
        .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

Does that look a little better?

Echognome · 30-May-2007, 07:16 PM **#20**

Hi Zach,

I can't get your modification to run. It keeps giving me class errors. Does it work on yours?

I'm also having a hard time with my undo module. It keeps erasing shapes that I don't want it to erase. I just want it to erase the shapes that have as their characters "Table of Contents". But it seems to take other shapes with it. Any suggestions?

Code:

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, tmpshape As Shape
    '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
                    End If
                    Next j
                End If
            End If
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
    Call ToggleEvents(True)
End Sub

End If
continueLoop:
Next i
Sheets(1).Select
ExitHere:
Call ToggleEvents(True)
End Sub

(It seems to cut off some of the code, so I added in the rest)

Zack Barresse · 04-Jun-2007, 12:07 AM **#21**

Slightly amended code. Buttons delete (except the chart sheet, really not sure how to patch that, but it looks seamless..) and hyperlinks colors match...

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, btn As MSForms.CommandButton
    '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
    Call UndoTOC(ActiveWorkbook)
    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
                .Range("C" & nRow).Font.ColorIndex = 5
                .Range("C" & nRow).Font.Underline = 2
                '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
                cb.Name = wkb.Sheets(i).Name
                '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 = 2
                    End With
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
                    '                    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignJustify
                    .OnAction = "Module2.GotoChart"
                End With
                .Range("B" & nRow).Value = nRow - 3
                .Range("B" & nRow).Interior.ColorIndex = shtColor
                nRow = nRow + 1
            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.Name = TOCname
                Selection.Characters.Text = "Table of Contents"
                With Selection.Characters(Start:=1, Length:=17).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("C4", .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
        .Range(.Cells(.Rows.Count, 3).End(xlUp).Offset(1, -1), _
               .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)).Delete shift:=xlUp
        .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 = obj.Name
    Range("C:C").Find(objName).Font.ColorIndex = 13
    '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
    Exit Sub
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()
    On Error Resume Next
    Sheets("Table of Contents").Select
    If Err.Number <> 0 Then
        MsgBox "Table of Contents not found!", vbInformation, "ERROR!"
    End If
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, cWs As Chart, i As Long, oleBtn As Variant
    '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
    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 Not IsChart(wkb.Sheets(i).Name, wkb) Then
            Set ws = wkb.Sheets(i)
            For Each oleBtn In ws.Shapes
                If oleBtn.Name = TOCname Then oleBtn.Delete
            Next oleBtn
        End If
continueLoop:
    Next i
    Sheets(1).Select
ExitHere:
End Sub

Let me know how it works. HTH

Echognome · 05-Jun-2007, 07:20 PM **#22**

Zack,

Thanks for your continued work on this. I still can't get the chartsheets to work properly, but at least I solved the Undo. The key was to name the shapes up above when you create them. If you just msgbox the names of the shapes otherwise it will read "Autoshape 4" or "Rectangle 5", etc. So I added a line that said:

With Selection
.Name = TOC Name

up above. That way, it knew what to delete later on.

Regards,
Matt

Tag Cloud
access acer asus bios bsod computer crash desktop dns driver drivers error ethernet excel freeze gaming graphics hard drive hardware hdmi internet laptop malware memory monitor motherboard network printer problem ram registry repair 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

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!