VBA to create Table of Content but EXCLUDE xlSheetHidden andxlSheetVeryHidden
Hi All,
I found the below code from VBAX Knowledgebase. However, I need the modified the code to "exclude/skip" all the xlSheetHidden and xlSheetVeryHidden. Can you please 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
Reply With Quote
