Question

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

错误是：

“运行时错误”-2147417848（80010108）'：方法'删除'object'_Worksheet'failed“

调试器指向删除内容表下的“工作表（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

Answer 1

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

创建了一本包含两张纸的新书，将其重命名为“作业列表”并将代码粘贴到其模块中。不得不为未定义的myAnswer变量添加声明。跑了代码。

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

将您的代码移动到标准模块，它应该运行正常。

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

1 个答案: