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

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

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

这在VBA中引发了'424'对象所需的错误，我花了几个小时试图解决这个问题，我不知道为什么会出现这个问题。 我不正确地select行吗？ 物体？

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

这是我的代码：

 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 

这是我得到的错误：

Answer 1

我想现在正在发生的事情是当你删除行时，你正在失去对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 

Answer 2

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

 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来避免一旦find匹配就跳出内部循环。 我不认为你应该“重置cell1”，因为这可能会污染循环迭代。