Excel VBA运行时错误'424'删除行时需要对象

Question

我正在尝试比较两个工作表（Sheet1和Sheet2）之间的单元格值，以查看它们是否匹配，如果匹配，则将Sheet1中的匹配值移动到预先存在的列表中（Sheet3），然后删除Sheet1中的值。

我在Excel VBA中使用反向For循环，但是一切都正常，直到我开始使用newrange1.EntireRow.Delete删除行的部分。

这会在VBA中引发“424”对象所需的错误，我已经花了几个小时来解决这个问题，我不确定为什么会出现这种情况。我是否选择了错误的行或对象？

如果有人能指导我正确的方向，我将不胜感激。

以下是我的代码：

Sub Step2()

    Sheets("Sheet1").Activate

    Dim counter As Long, unsubListCount As Long, z As Long, x As Long, startRow As Long
    counter = 0
    startRow = 2
    z = 0
    x = 0

    ' Count Sheet3 Entries
    unsubListCount = Worksheets("Sheet3").UsedRange.Rows.Count

    Dim rng1 As Range, rng2 As Range, cell1 As Range, cell2 As Range, newrange1 As Range

    ' Select all emails in Sheet1 and Sheet2 (exclude first row)
    Set rng1 = Worksheets("Sheet1").Range("D1:D" & Worksheets("Sheet1").UsedRange.Rows.Count)
    Set rng2 = Worksheets("Sheet2").Range("D1:D" & Worksheets("Sheet2").UsedRange.Rows.Count)

   ' Brute Loop through each Sheet1 row to check with Sheet2
    For z = rng1.Count To startRow Step -1
        'Cells(z, 4)
        Set cell1 = Worksheets("Sheet1").Cells(z, "D")
        For x = rng2.Count To startRow Step -1
            Set cell2 = Worksheets("Sheet2").Cells(x, "D")

            If cell1.Value = cell2.Value Then ' If rng1 and rng2 emails match
                counter = counter + 1
                Set newrange1 = Worksheets("Sheet1").Rows(cell1.Row)

                newrange1.Copy Destination:=Worksheets("Sheet3").Range("A" & unsubListCount + counter)
                newrange1.EntireRow.Delete
            End If
        Next
    Next
End Sub

我遇到的错误如下图所示:

注：本文中的HTML标签已保留。

- Kyle Yeo

---

你的内部循环产生了许多不必要的工作量。改用 Application.Match 会更好。 - user4039065

只是一个想法，因为我曾经遇到过类似的问题：在重新分配它们到新范围之前（可能是在循环结束前的...next...之前），插入新的代码行，例如 Set cell1 = Nothing 和 Set newrange1 = Nothing。 - Ralph

在执行 .EntireRow.Delete 之前，可以在立即窗口中检查 ? newrange1.Address。 https://www.excelcampus.com/vba/vba-immediate-window-excel/ - Ralph

@GSerg @Ralph，执行Msgbox newrange1.Address会返回“$13:$13”。这是一个有效的地址，对吧？ - Kyle Yeo

@GSerg @Ralph，看起来@Ryan可能解决了我的问题——我想那就是这样了——我需要将newrange1设置为Nothing，然后将cell1重置为下一个单元格。谢谢大家！ - Kyle Yeo

Answer 1

你的内部循环产生了很多逐步完成的工作，最好使用Application.Match来完成。通过从底部向上查找最后一个值来检索D列中值的范围，而不是使用.UsedRange更好。

Option Explicit

Sub Step2()

    Dim z As Long, startRow As Long
    Dim rng2 As Range, wk3 As Worksheet, chk As Variant

    startRow = 2
    z = 0
    Set wk3 = Worksheets("Sheet3")

    ' Select all emails in Sheet1 and Sheet2 (exclude first row)
    With Worksheets("Sheet2")
        Set rng2 = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
    End With

    With Worksheets("Sheet1")
        For z = .Cells(.Rows.Count, "D").End(xlUp).Row To startRow Step -1
            chk = Application.Match(.Cells(z, "D").Value2, rng2, 0)
            If Not IsError(chk) Then
                .Cells(z, "A").EntireRow.Copy _
                    Destination:=wk3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                .Cells(z, "A").EntireRow.Delete
            End If
        Next
    End With
End Sub

正如Ryan Wildry所指出的那样，您最初的问题在于在删除行后继续循环并进行比较。可以通过在newrange1.EntireRow.Delete后添加Exit For来避免这种情况，以便在找到匹配项后跳出内部循环。我认为您不应该“重置cell1”，因为这可能会破坏循环迭代。

- user4039065

---

谢谢！我会把这个集成到我的代码中。非常感谢！ - Kyle Yeo

Answer 2

我认为发生的情况是当您删除该行时，您丢失了对范围Cell1的引用。因此，在删除完成后，我重置了它，并删除了对newRange1的引用。尝试一下，我在我的端口上运行成功。我也稍微格式化了代码。

Option Explicit

Sub Testing()

    Dim counter         As Long: counter = 0
    Dim z               As Long: z = 0
    Dim x               As Long: x = 0
    Dim startRow        As Long: startRow = 2
    Dim Sheet1          As Worksheet: Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
    Dim Sheet2          As Worksheet: Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
    Dim Sheet3          As Worksheet: Set Sheet3 = ThisWorkbook.Sheets("Sheet3")
    Dim rng1            As Range: Set rng1 = Sheet1.Range("D1:D" & Sheet1.UsedRange.Rows.Count)
    Dim rng2            As Range: Set rng2 = Sheet2.Range("D1:D" & Sheet2.UsedRange.Rows.Count)
    Dim unsubListCount  As Long: unsubListCount = Sheet3.UsedRange.Rows.Count
    Dim cell1           As Range
    Dim cell2           As Range
    Dim newrange1       As Range

   ' Brute Loop through each Sheet1 row to check with Sheet2
    For z = rng1.Count To startRow Step -1
        Set cell1 = Sheet1.Cells(z, 4)
        For x = rng2.Count To startRow Step -1
            Set cell2 = Sheet2.Cells(x, 4)
            If cell1 = cell2 Then
                counter = counter + 1
                Set newrange1 = Sheet1.Rows(cell1.Row)
                newrange1.Copy Destination:=Sheet3.Range("A" & unsubListCount + counter)
                newrange1.EntireRow.Delete
                Set newrange1 = Nothing
                Set cell1 = Sheet1.Cells(z, 4)
            End If
        Next
    Next
End Sub

- Ryan Wildry

---

需要注意的是，在 newrange1.EntireRow.Delete 后面添加这两行代码 Set newrange1 = Nothing 和 Set cell1 = Sheet1.Cells(z, 4) 就解决了问题。谢谢！ - Kyle Yeo

@KyleYeo，我猜你错过了我之前在这方面的评论：https://dev59.com/dp_ha4cB1Zd3GeqP4ciP#VNjonYgBc1ULPQZFhMhD 然后我们本可以更早地解决它。RyanWildry：感谢你把那个完整的回复做出来。 - Ralph

@Ralph 是的，我意识到了——太多的评论同时涌入... - Kyle Yeo