PDA

View Full Version : [SOLVED] Excluding worksheets from the Table of Contents



oam
10-25-2013, 07:37 AM
The code that Zack Barresse posted some time back works well for me in creating a table of contents. I am making a form that makes a copy of the Master worksheet, adds it to the workbook, and names it based on the names in a list in the Name worksheet. My question is, is there is a way to exclude certain worksheet from the newly created Table of Contents? The user of the form does not need access to the Master, Names, or the Lookup worksheets that or used for other function within the workbook.

Thank you for your help.






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 = 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. 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
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 - 2
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

p45cal
10-25-2013, 12:43 PM
Immediately after the line:
For i = 2 to N
add the line:
If IsError(Application.Match(Sheets(i).Name, Array("Master", "Names", "Lookup"), 0)) Then
and immediately before the line:
continueLoop:
add the line:
End If
Adjust the sheet names in red above to suit you, as well as adding or removing names. Only include names of sheets here that you don't want to appear in the TOC.

As an aside, does the code always miss out the rightmost sheet in the TOC as it seems to do here?

oam
10-28-2013, 07:19 PM
Thank you for your help, the code worked perfectly. I have one additional question about the hyperlinks that the code creates, is there a way to protect the worksheet to prevent the users from deleting the hyperlinks and the hyperlinks continue to work?

p45cal
10-28-2013, 11:11 PM
Protect the sheet? Either manually, or in code: at the end of the macro add the line in red below:

With Sheets("TOC")
.Range("C:C").EntireColumn.AutoFit
.Range("A4").Activate
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

?


Can I ask again, does the code always miss out the rightmost sheet in the TOC? That's to say, the rightmost sheet/tab does not appear on the table of contents here; is it the same with you?

oam
10-29-2013, 03:38 PM
p45cal,

To answer your question, yes the right most worksheet did not appear in the TOC when I ran the code but I adjusted the "Variables for loop/iterations" in the code (change to code included below) and if the TOC is the first worksheet the code will include all additional worksheets to the right of the TOC.

To follow up on my additional question, I added the line of code as instructed but the hyperlinks will not work unless I unprotect the worksheet, any ideas?

Thanks for your help




'Set variables for loop/iterations
N = ActiveWorkbook.Sheets.Count + tmpCount
If x = 1 Then N = N - 1
For i = 2 To N

p45cal
10-29-2013, 05:36 PM
No problem with non-working hyperlinks here when he sheet is protected. If you protect the sheet manually, what checkboxes are checked in the Protect Sheet dialogue box? I suspect that Select Locked cells and Select unlocked cells will both be unticked. I think Excel remembers what was ticked before. Make sure they are both ticked and try again.
Otherwise, I think the same is achieved with:
ActiveSheet.EnableSelection = xlNoRestrictions
after the .Protect line