• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Table of Contents - Adding a button to update

H

HollyOsburn

New Member
Hello - I am brand new to VBA, but reading everything I can find and walking through tutorials and examples etc. I have added a Table of Contents module to my workbooks due to a huge number of sheets required in each. I would like to make this more user-friendly, by adding an "Update" button, but each time I do so, I wipe out the button when I re-create the TOC. I know why this happens, because each time I build the new TOC it completely overwrites the existing. What I need to know is how to "refresh" instead of "recreate" the data, and also how to include the button on the page in the first place.


I know this is a lot of detail, but if someone could send me to an example workbook that has something similar even, I would be very grateful and try to figure out how to modify on my own.


Thank you.
 
Hi Holly. Welcome to the forum, and the world of VB.

Would you mind posting the code that you are currently using to create the ToC? That would save us the most time, so we can just adapt what you already have.
 
@SirJB7

Hi, myself, so long...

And if Luke M adapts the code, that'd surely save my whole time :=)

Regards!
 
Or, here's a simple TOC macro you can use.

[pre]
Code: 
Sub TOC()
Dim sCount As Long
Dim tocSh As String
Dim sName As String
Dim listCount As Long

'Name of worksheet where Table of Contents is at
tocSh = "Sheet1"

sCount = ThisWorkbook.Worksheets.Count
Application.ScreenUpdating = False
With Worksheets(tocSh)
'clear previous cells
.Range("A2:A1000").ClearContents
listCount = 0
For i = 1 To sCount
sName = ThisWorkbook.Worksheets(i).Name
If sName <> tocSh Then
.Hyperlinks.Add anchor:=.Cells(2 + listCount, "A"), Address:="", _
SubAddress:=sName & "!A1", TextToDisplay:=sName
listCount = listCount + 1
End If
Next i
End With
Application.ScreenUpdating = True

End Sub
[/pre]
 
You all ROCK. Thank you for the quick and helpful responses. I am going to try with the 'new' code shared above, but here is the original code I was working with. This (obviously is not my own original work - but was provided somewhere on the internet - my apologies for not having the original link available. My only updates were very minor in Text and numbering.

Option Explicit

Sub CreateTOC()
'Declare all variables
Dim ws As Worksheet, curws As Worksheet, shtName As String
Dim nRow As Long, i As Long, N As Long, x As Long, tmpCount As Long
Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String
Dim cCnt As Long, cAddy As String, cShade As Long
'Check if a workbook is open or not. If no workbook is open, quit.
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'-------------------------------------------------------------------------------
cShade = 45 '<<== 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. 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:50").RowHeight = 16
.Range("A1").Value = "Optum IE - TBA Internal TFS Tracking Tool"
.Range("A1").Font.Bold = False
.Range("A1").Font.Italic = True
.Range("A1").Font.Name = "Arial"
.Range("A1").Font.Size = "8"
.Range("A2").Value = "Client Implementations in this Workbook"
.Range("A2").Font.Bold = True
.Range("A2").Font.Name = "Arial"
.Range("A2").Font.Size = "18"
.Range("A4").Select
End With
'Set variables for loop/iterations
N = ActiveWorkbook.Sheets.Count + tmpCount
If x = 1 Then N = N - 1
For i = 2 To N
With Sheets("TOC")
'Check if sheet is a chart sheet.
If IsChart(Sheets(i).Name) Then
'** Sheet IS a Chart Sheet
cCnt = cCnt + 1
shtName = 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
.OnAction = "Mod_Main.GotoChart"
End With
Else
'** Sheet is NOT a Chart sheet.
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
End If
.Range("B" & nRow).Value = nRow - 3
nRow = nRow + 1
End With
continueLoop:
Next i
'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

Public Function IsChart(cName As String) 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 = 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
'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
End Sub

Private Sub CommandButton1_Click()

UserForm1.Show

End Sub
 
THANK YOU Thank You Thank you! This is what I was hoping to get to and it works. I added a button to the page and assigned the "TOC" macro to it, and it's simple and works.


Hope to keep learning and one day contribute back to others!
 
Thanks for sharing the other code, and for the feedback. We're glad we could help, and look forward to you coming back again sometime.
 
You must log in or register to reply here.
Back
Top