CODEWITHSUNDEEP
vbaexcel
Kyle Yeo
Kyle Yeo

Reputation: 2368

Excel VBA Runtime Error '424' Object Required when deleting rows

I'm trying to compare cell values between 2 Sheets (Sheet1 & Sheet2) to see if they match, and if they match move the matching values in Sheet1 to a pre-existing list (Sheet3) and delete the values in Sheet1 afterwards.

I'm using the reverse For Loop in Excel VBA, but everything works until the part where I start deleting the row using newrange1.EntireRow.Delete.

This throws a '424' Object Required Error in VBA and I've spent hours trying to solve this, I'm not sure why this is appearing. Am I selecting the row incorrectly? The object?

Would appreciate if anyone can point me to the correct direction.

Here's my code:

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

Here's the error I'm getting:

424 Object Required

Upvotes: 7

Views: 3310

Answers (2)

Ryan Wildry
Ryan Wildry

Reputation: 5677

I think what's happening is when you are deleting the row, you are losing the reference to the range Cell1. So I reset this after the deletion is done, and removed the reference to newRange1. Give this a shot, I have it working on my end. I also formatted the code slightly too.

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

Upvotes: 3

user4039065
user4039065

Reputation:

Your inner loop produces a lot of step-by-step work that is better accomplished with Application.Match. Your use of .UsedRange to retrieve the extents of the values in the D columns is better by looking for the last value from the bottom up.

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

As noted by Ryan Wildry, your original problem was continuing the loop and comparing after deleting the row. This can be avoided by adding Exit For after newrange1.EntireRow.Delete to jump out of the inner loop once a match was found. I don't think you should 'reset cell1' as this may foul up the loop iteration.

Upvotes: 5

Related Questions