VBA生成工作表目录时如何排除隐藏或指定工作表？

我有一段用于生成工作表目录的VBA代码，需要跳过名为"Ukryte"的隐藏工作表，但尝试以下三种条件判断写法后，均出现Subscript out of range（下标越界）错误，错误发生在循环或目录生成环节：

1. 错误写法1

If sht.Name <> ContentName Or sht.Name <> "Ukryte" Then
      myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht

2. 错误写法2

If sht.Name = ContentName Or sht.Name = "Ukryte" Then

Else
  myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht 

3. 错误写法3

If sht.Name = ContentName Then
ElseIf sht.Name = "Ukryte" Then
Else 
  myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht

完整原代码如下：

Sub Spis_Treści()

'PURPOSE: Add a Table of Contents worksheets to easily navigate to any tab
'SOURCE: www.TheSpreadsheetGuru.com

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

'Inputs
  ContentName = "Spis Treści"
  
'Optimize Code
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False

'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets("Spis Treści").Activate
  On Error GoTo 0

  If ActiveSheet.Name = "Spis Treści" Then
    myAnswer = MsgBox("Czy chcesz zaktualizować Spis Treści?", vbYesNo)
    
    'Did user select No or Cancel?
      If myAnswer <> vbYes Then GoTo ExitSub
      
    'Delete old Contents Tab
      Worksheets("Spis Treści").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") = "Numery zleceń"
    .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
   
    Else
      myArray(x + 1) = sht.Name
      x = x + 1
    End If
  Next sht
  
'Alphabetize Sheet Names in Array List
  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

'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", _
      TextToDisplay:=sht.Name
      .Cells(x + 2, 2).Value = x
    End With
  Next x
  
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit

'A Splash of Guru Formatting! [Optional]
  Columns("A:B").ColumnWidth = 3.86
  Range("B1").Font.Size = 18
  Range("B1:F1").Borders(xlEdgeBottom).Weight = xlThin
  
    Columns("C:C").Select
    Range("C2").Activate
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Range("B1:F1").Merge
  With Range("B1:F1")
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
 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(91, 155, 213)
End With

  'Adjust Zoom and Remove Gridlines
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.Zoom = 130

ExitSub:
'Optimize Code
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
End Sub

错误原因分析 #

1. 逻辑判断错误：第一种写法中sht.Name <> ContentName Or sht.Name <> "Ukryte"永远为真，因为一个工作表不可能同时等于两个不同名称，导致所有工作表都被加入数组，包括需要排除的表。
2. 数组大小不匹配：原代码初始化数组时使用ReDim myArray(1 To Worksheets.Count - 1)，只考虑排除目录表；当新增排除"Ukryte"表后，有效工作表数量变为Worksheets.Count - 2，数组中会出现空元素，后续遍历数组时Worksheets(myArray(x))找不到对应工作表，触发下标越界错误。

解决方案 #

方案1：跳过指定隐藏表"Ukryte" #

修改数组生成部分的代码，先统计有效工作表数量，再初始化数组，同时修正条件判断逻辑：

'Create Array list with sheet names (excluding Contents and "Ukryte")
  Dim sheetCount As Long
  sheetCount = 0
  
  '统计需要保留的工作表数量
  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName And sht.Name <> "Ukryte" Then
      sheetCount = sheetCount + 1
    End If
  Next sht
  
  '初始化数组
  ReDim myArray(1 To sheetCount)
  
  x = 0
  '填充数组
  For Each sht In ActiveWorkbook.Worksheets
    If sht.Name <> ContentName And sht.Name <> "Ukryte" Then
      x = x + 1
      myArray(x) = sht.Name
    End If
  Next sht

方案2：跳过所有隐藏工作表 #

如果需要排除所有隐藏表，将条件改为判断工作表可见性：

'Create Array list with sheet names (excluding Contents and hidden sheets)
  Dim sheetCount As Long
  sheetCount = 0
  
  '统计需要保留的工作表数量
  For Each sht In ActiveWorkbook.Worksheets
    If sht.Visible = xlVisible And sht.Name <> ContentName Then
      sheetCount = sheetCount + 1
    End If
  Next sht
  
  '初始化数组
  ReDim myArray(1 To sheetCount)
  
  x = 0
  '填充数组
  For Each sht In ActiveWorkbook.Worksheets
    If sht.Visible = xlVisible And sht.Name <> ContentName Then
      x = x + 1
      myArray(x) = sht.Name
    End If
  Next sht

修改后完整代码 #

将原代码中数组生成的部分替换为上述代码即可，其余部分保持不变。

内容的提问来源于stack exchange，提问作者Bearly