Table of Contents | How i can create it without hidden Sheets?

[pacosalasv]

Helo Experts, i need your support!

I modified a Macro Downloaded from Web, Its allocated in a Module for my Excel File in order to Create Table of Contents. The problem is that it includes HIDDEN sheets as well as part of the list. How i can create it without the hidden ones?

Here is the Full Module Code:

'*** Create Table of Contents for Workbook START ***

Sub Generate_TOC()

Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim shtName1 As String, shtName2 As String
Dim ContentName As String

Call Functions.OptimizeCodeSpeed
x = 0 'Clear X Variable to avoid errors

'Inputs
  ContentName = "Table of Contents"
  
'Set variables
  Const bSkipHidden As Boolean = False 'Change this to True to NOT list hidden sheets

'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets(ContentName).Activate
  On Error GoTo 0

  If ActiveSheet.Name = ContentName Then
    myAnswer = MsgBox("A worksheet named [" & ContentName & "] has already been created, would you like to replace it?", vbExclamation + vbYesNo)
    
    'Did user select No or Cancel?
      If myAnswer <> vbYes Then GoTo ErrorHandler
            
    'Delete old Contents Tab
      Worksheets(ContentName).Delete
  End If

'Create New Contents Sheet
  Worksheets.Add Before:=Worksheets(1)

'Set variable to Contents Sheet
  Set Content_sht = ActiveSheet

'Format Contents Sheet
  With Content_sht
    .Name = ContentName
    .Range("B1") = "Table of Contents"
    .Range("B1").Font.Bold = True
  End With

'Create Array list with sheet names (excluding Contents)
  ReDim myArray(1 To Worksheets.Count - 1)

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName Then
      myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht

  'Ask if Alphabetize Sheet Names in Array List
  Sort = MsgBox("Do you want to sort in Alphabetical Order the Table of Contents?", vbQuestion + vbYesNo, "Sort Table of Contents")
    
    If Sort <> vbNo Then
         
          For x = LBound(myArray) To UBound(myArray)
            For y = x To UBound(myArray)
              If UCase(myArray(y)) < UCase(myArray(x)) Then
                shtName1 = myArray(x)
                shtName2 = myArray(y)
                myArray(x) = shtName2
                myArray(y) = shtName1
              End If
             Next y
          Next x
    
    End If

'Create Table of Contents
  For x = LBound(myArray) To UBound(myArray)
    Set sht = Worksheets(myArray(x))
    sht.Activate
    With Content_sht
      .Hyperlinks.Add .Cells(x + 2, 3), "", _
      SubAddress:="'" & sht.Name & "'!A1", _
      ScreenTip:="Click to Go: " & sht.Name & " Sheet", _
      TextToDisplay:=sht.Name
      .Cells(x + 2, 2).Value = x
    End With
  Next x
  
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit

'Formatting! [Optional]
  Columns("A:B").ColumnWidth = 4
  Range("B1").Font.Size = 12
  Range("B1:D1").Merge
  Range("B1:D1").Borders(xlEdgeBottom).Weight = xlThin
    
  With Range("A1")
  
    .Value = ChrW(&HD83E) & ChrW(&HDDFE) 'Unicode Character 'RECEIPT' (U+1F9FE)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  
  End With
  
  With Range("B3:B" & x + 1)
  
    .Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
    .Borders(xlInsideHorizontal).Weight = xlMedium
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Color = RGB(255, 255, 255)
    .Interior.Color = RGB(0, 164, 227)
    
  End With

     ActiveWindow.DisplayGridlines = False 'Deactivate Gridlines
     ActiveWindow.DisplayHeadings = False 'Deactivate Headings
     Columns("F:XFD").EntireColumn.Hidden = True
     ActiveWindow.Zoom = 100
        
    Call ChangeStyleIfHyperLink
    
ErrorHandler:
      
    Application.DisplayAlerts = True
    Call Functions.OptimizeCodeSpeedRestore
    
    Exit Sub
    
End Sub

Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
  
  If IsChart(Target.Name) Then
    
    ThisWorkbook.Sheets(Target.Name).Activate
  
  End If
  
End Sub

Function IsHyperlink(r As Range) As Integer

    IsHyperlink = r.Hyperlinks.Count

End Function

Sub ChangeStyleIfHyperLink()

'Change Font Style if its HyperLink in active sheet

    Dim r As Range, c As Range
    
    Set r = Range(Range("C3"), Range("C3").End(xlDown))
    
    For Each c In r
    If IsHyperlink(c) Then
    
        With c.Font
                
                .Name = "Gill Sans MT"
                '.FontStyle = "Bold"
                '.Size = 12
                '.Strikethrough = False
                '.Superscript = False
                '.Subscript = False
                '.OutlineFont = False
                '.Shadow = False
                '.Underline = xlUnderlineStyleNone
                .ColorIndex = 25
        
        End With
    
    End If
    
    Next

End Sub

Function IsChart(cName As String) As Boolean
     
Dim tmpChart As Chart
     
    On Error Resume Next
      Set tmpChart = Charts(cName)
    On Error GoTo 0
    
    IsChart = IIf(tmpChart Is Nothing, False, True)
     
End Function

Sub Contents_Hyperlinks()
'Button to All Sheets come Back to Table of Contents

Dim sht As Worksheet
Dim shp As Shape
Dim ContentName As String
Dim ButtonID As String

On Error GoTo ErrorHandler

Call Functions.OptimizeCodeSpeed
    
'Inputs:
  ContentName = "Table of Contents" 'Table of Contents Worksheet Name
  ButtonID = "_ContentButton" 'ID to Track Buttons for deletion
  
'Loop Through Each Worksheet in Workbook
  For Each sht In ActiveWorkbook.Worksheets
  
    If sht.Name <> ContentName Then
      
      'Delete Old Button (if necessary when refreshing)
        For Each shp In sht.Shapes
          If Right(shp.Name, Len(ButtonID)) = ButtonID Then
            shp.Delete
            Exit For
          End If
        Next shp
        
      'Create & Position Shape
        Set shp = sht.Shapes.AddShape(msoShapeRoundedRectangle, _
          4, 4, 90, 20)

      'Format Shape
        shp.Fill.ForeColor.RGB = RGB(0, 164, 227) 'Blue
        shp.Line.Visible = msoFalse
        shp.TextFrame2.TextRange.Font.Size = 10
        shp.TextFrame2.TextRange.Text = ContentName
        shp.TextFrame2.TextRange.Font.Bold = True
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) 'White
      
      'Track Shape Name with ID Tag
        shp.Name = shp.Name & ButtonID
      
      'Assign Hyperlink to Shape
        sht.Hyperlinks.Add shp, "", _
          SubAddress:="'" & ContentName & "'!A1"
  
    End If
    
  Next sht

ErrorHandler:
      
    Call Functions.OptimizeCodeSpeedRestore
    
    Exit Sub

End Sub

[mehmetcik]

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName and sht.visible = True Then
      myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName and sht.visible = True Then S = S + sht.name &":"
  Next sht

  myArray = Split(S, ":")

[pacosalasv]

It doesn't work, Debug error with

Set sht = Worksheets(myArray(x))

Any other suggestion / recommendation?

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName and sht.visible = True Then
      myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName and sht.visible = True Then S = S + sht.name &":"
  Next sht

  myArray = Split(S, ":")

[Andy Pope]

It looks like the code already handles hidden sheets if you use the const in the code to ignore hidden sheets. Did you try that?

'Set variables
  Const bSkipHidden As Boolean = False 'Change this to True to NOT list hidden sheets

[pacosalasv]

I tried but not working, probably im using wrong code or logic.

could you help me with it, i mean, where and how i need to place it?

Thanks

[Andy Pope]

I'm guessing that you modified the code such that you removed the code to deal with hidden sheets.

Modify the loop that builds the names of sheets to deal with.

'Create Array list with sheet names (excluding Contents)
  ReDim myArray(1 To Worksheets.Count - 1)

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName Then
      If Not sht.Visible = xlSheetVisible Then
        If Not bSkipHidden Then
          myArray(x + 1) = sht.Name
          x = x + 1
        End If
      Else
          myArray(x + 1) = sht.Name
          x = x + 1
      End If
    End If
  Next sht
  ReDim Preserve myArray(1 To x)

The const still needs to be changed depending on whether hidden sheets are to be included or not.

'Set variables
  Const bSkipHidden As Boolean = True 'Change this to True to NOT list hidden sheets

[pacosalasv]

Works Flawless!!!

Thanks for support, if some one needs here is the code corrected with @Andy Pope support

'*** Create Table of Contents for Workbook START ***

Sub Generate_TOC()

Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim shtName1 As String, shtName2 As String
Dim ContentName As String

Call Functions.OptimizeCodeSpeed
x = 0 'Clear X Variable to avoid errors

'Inputs
  ContentName = "Table of Contents"
  
'Set variables
  Const bSkipHidden As Boolean = True 'Change this to True to NOT list hidden sheets

'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets(ContentName).Activate
  On Error GoTo 0

  If ActiveSheet.Name = ContentName Then
    myAnswer = MsgBox("A worksheet named [" & ContentName & "] has already been created, would you like to replace it?", vbExclamation + vbYesNo)
    
    'Did user select No or Cancel?
      If myAnswer <> vbYes Then GoTo ErrorHandler
            
    'Delete old Contents Tab
      Worksheets(ContentName).Delete
  End If

'Create New Contents Sheet
  Worksheets.Add Before:=Worksheets(1)

'Set variable to Contents Sheet
  Set Content_sht = ActiveSheet

'Format Contents Sheet
  With Content_sht
    .Name = ContentName
    .Range("B1") = "Table of Contents"
    .Range("B1").Font.Bold = True
  End With

'Create Array list with sheet names (excluding Contents)
  ReDim myArray(1 To Worksheets.Count - 1)

  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName Then
      If Not sht.Visible = xlSheetVisible Then
        If Not bSkipHidden Then
          myArray(x + 1) = sht.Name
          x = x + 1
        End If
      Else
          myArray(x + 1) = sht.Name
          x = x + 1
      End If
    End If
  Next sht
  ReDim Preserve myArray(1 To x)

  'Ask if Alphabetize Sheet Names in Array List
  Sort = MsgBox("Do you want to sort in Alphabetical Order the Table of Contents?", vbQuestion + vbYesNo, "Sort Table of Contents")
    
    If Sort <> vbNo Then
         
          For x = LBound(myArray) To UBound(myArray)
            For y = x To UBound(myArray)
              If UCase(myArray(y)) < UCase(myArray(x)) Then
                shtName1 = myArray(x)
                shtName2 = myArray(y)
                myArray(x) = shtName2
                myArray(y) = shtName1
              End If
             Next y
          Next x
    
    End If

'Create Table of Contents
  For x = LBound(myArray) To UBound(myArray)
    Set sht = Worksheets(myArray(x))
    sht.Activate
    With Content_sht
      .Hyperlinks.Add .Cells(x + 2, 3), "", _
      SubAddress:="'" & sht.Name & "'!A1", _
      ScreenTip:="Click to Go: " & sht.Name & " Sheet", _
      TextToDisplay:=sht.Name
      .Cells(x + 2, 2).Value = x
    End With
  Next x
  
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit

'Formatting! [Optional]
  Columns("A:B").ColumnWidth = 4
  Range("B1").Font.Size = 12
  Range("B1:D1").Merge
  Range("B1:D1").Borders(xlEdgeBottom).Weight = xlThin
    
  With Range("A1")
  
    .Value = ChrW(&HD83E) & ChrW(&HDDFE) 'Unicode Character 'RECEIPT' (U+1F9FE)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  
  End With
  
  With Range("B3:B" & x + 1)
  
    .Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
    .Borders(xlInsideHorizontal).Weight = xlMedium
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Color = RGB(255, 255, 255)
    .Interior.Color = RGB(0, 164, 227)
    
  End With

     ActiveWindow.DisplayGridlines = False 'Deactivate Gridlines
     ActiveWindow.DisplayHeadings = False 'Deactivate Headings
     Columns("F:XFD").EntireColumn.Hidden = True
     ActiveWindow.Zoom = 100
        
    Call ChangeStyleIfHyperLink
    
ErrorHandler:
      
    Application.DisplayAlerts = True
    Call Functions.OptimizeCodeSpeedRestore
    
    Exit Sub
    
End Sub

Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
  
  If IsChart(Target.Name) Then
    
    ThisWorkbook.Sheets(Target.Name).Activate
  
  End If
  
End Sub

Function IsHyperlink(r As Range) As Integer

    IsHyperlink = r.Hyperlinks.Count

End Function

Sub ChangeStyleIfHyperLink()

'Change Font Style if its HyperLink in active sheet

    Dim r As Range, c As Range
    
    Set r = Range(Range("C3"), Range("C3").End(xlDown))
    
    For Each c In r
    If IsHyperlink(c) Then
    
        With c.Font
                
                .Name = "Gill Sans MT"
                '.FontStyle = "Bold"
                '.Size = 12
                '.Strikethrough = False
                '.Superscript = False
                '.Subscript = False
                '.OutlineFont = False
                '.Shadow = False
                '.Underline = xlUnderlineStyleNone
                .ColorIndex = 25
        
        End With
    
    End If
    
    Next

End Sub

Function IsChart(cName As String) As Boolean
     
Dim tmpChart As Chart
     
    On Error Resume Next
      Set tmpChart = Charts(cName)
    On Error GoTo 0
    
    IsChart = IIf(tmpChart Is Nothing, False, True)
     
End Function

Sub Contents_Hyperlinks()
'Button to All Sheets come Back to Table of Contents

Dim sht As Worksheet
Dim shp As Shape
Dim ContentName As String
Dim ButtonID As String

On Error GoTo ErrorHandler

Call Functions.OptimizeCodeSpeed
    
'Inputs:
  ContentName = "Table of Contents" 'Table of Contents Worksheet Name
  ButtonID = "_ContentButton" 'ID to Track Buttons for deletion
  
'Loop Through Each Worksheet in Workbook
  For Each sht In ActiveWorkbook.Worksheets
  
    If sht.Name <> ContentName Then
      
      'Delete Old Button (if necessary when refreshing)
        For Each shp In sht.Shapes
          If Right(shp.Name, Len(ButtonID)) = ButtonID Then
            shp.Delete
            Exit For
          End If
        Next shp
        
      'Create & Position Shape
        Set shp = sht.Shapes.AddShape(msoShapeRoundedRectangle, _
          4, 4, 90, 20)

      'Format Shape
        shp.Fill.ForeColor.RGB = RGB(0, 164, 227) 'Blue
        shp.Line.Visible = msoFalse
        shp.TextFrame2.TextRange.Font.Size = 10
        shp.TextFrame2.TextRange.Text = ContentName
        shp.TextFrame2.TextRange.Font.Bold = True
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) 'White
      
      'Track Shape Name with ID Tag
        shp.Name = shp.Name & ButtonID
      
      'Assign Hyperlink to Shape
        sht.Hyperlinks.Add shp, "", _
          SubAddress:="'" & ContentName & "'!A1"
  
    End If
    
  Next sht

ErrorHandler:
      
    Call Functions.OptimizeCodeSpeedRestore
    
    Exit Sub

End Sub