奇怪的 excel-vba 运行时错误，不会删除现有工作表

Posted 2023-03-27

【中文标题】奇怪的 excel-vba 运行时错误，不会删除现有工作表

【英文标题】：Odd excel-vba run-time Error and won't delete existing sheet

【发布时间】：2017-06-28 08:57:30

【问题描述】：

我遇到了这个 VBA 错误，无法弄清楚为什么我每 第三次 运行宏时都会收到这个错误（前两个运行良好）。

错误是：

“运行时错误'-2147417848 (80010108)': 对象'_Worksheet'的方法'Delete'失败"

调试器指向代码中Delete Contents Sheet if it already存在下的“Worksheets(ContentName).Delete”注释。

此代码的目的：在一个工作表上创建一个目录，通过工作表名称链接到工作簿中的所有工作表

我创建了一个按钮，用于在添加新工作表时再次运行宏以更新目录。

Sub TableOfContents_Create()
'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 = "Job List"

'Optimize Code
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False

'Delete Contents Sheet if it already exists
  On Error Resume Next
    Worksheets("Job List").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?", vbYesNo)

    'Did user select No or Cancel?
      If myAnswer <> vbYes Then GoTo ExitSub

    '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("B2") = "Jobs"
    .Range("B2").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

'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

  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




'Pulls the name of the work book and displays it at the top
    With Content_sht
      .Name = ContentName
      .Range("B1") = ThisWorkbook.Name
      .Range("B1").Font.Bold = True
    End With


'Create a refresh button
    ActiveSheet.Buttons.Add(Range("G4").Left, Range("G4").Top, 90, 25).Select
    Selection.Name = "btnRefreshList"
    Selection.OnAction = "TableOfContents_Create"
    ActiveSheet.Shapes("btnRefreshList").Select
    With Selection
       .Characters.Text = "Refresh List"
        With .Font
            .Name = "Arial"
            .FontStyle = "Bold"
            .Size = 12
        End With
    End With

'Create a New Job Button
    ActiveSheet.Buttons.Add(Range("G2").Left, Range("G2").Top, 90, 25).Select
    Selection.Name = "btnNewJob"
    Selection.OnAction = "NewJob"
    ActiveSheet.Shapes("btnNewJob").Select
    With Selection
       .Characters.Text = "New Job"
        With .Font
            .Name = "Arial"
            .FontStyle = "Bold"
            .Size = 12
        End With
    End With

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

End Sub


'Create a new job worksheet
Private Sub NewJob()
Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Master")
    ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
End Sub

【问题讨论】：

我可以将此代码粘贴到一个新的空工作簿中，然后一遍又一遍地运行它而不会出错。通过运行宏或单击“刷新列表”按钮。我可以更改工作表的名称，并在列表中更改它们。新工作不起作用，因为我没有主表，但我认为这不是你的问题。你还有什么不一样的吗？编辑 - 如果作业列表是最后一张，我可以重现错误 - 你不能删除最后一张，这是问题吗？

感谢 mock_blatt 的回复。新建作业按钮应该复制一张已经命名为“Master”的工作表（所以任何东西都可以在该工作表中）。我知道如果作业列表是最后一张纸，则会弹出错误，但我的工作簿中还有其他纸。当我点击“刷新按钮”两次以上时，我得到了错误，它崩溃了。

这很有趣。您可以尝试打开一个全新的空白工作簿并将代码粘贴到那里吗？这就是我所做的并且它有效。如果它也在那里崩溃，我们知道这与您的环境有关。如果不是，则该特定工作簿还有其他内容。

【参考方案1】：

我打算评论说我无法重现错误，但@mock_blatt 给了我一个线索，可能代码正在工作表模块中运行。

用两张纸创建了一本新书，将其中一张重命名为 Job List 并将您的代码粘贴到它的模块中。必须为未定义的 myAnswer 变量添加声明。运行代码。

虽然您可以关闭运行代码的工作簿，但您似乎无法从工作表代码模块中运行的 Sub 中删除工作表

将您的代码移至标准模块，它应该可以正常运行。

【讨论】：

我会考虑将代码转移到一个新的工作簿中并会报告。谢谢！

感谢您查看此标记。我将代码放在标准模块下。我创建了一个名为“Master”的工作表，并从“开发人员”选项卡下的“宏”运行代码，并创建了带有按钮的新工作表“工作列表”。我通过单击添加作业并点击刷新按钮进行了测试，但在我每 3 次或第 4 次点击该刷新按钮时仍然会出现该错误。奇怪...