Excel VBA ошибка выполнения " 424 " объект требуется при удалении строк

Я пытаюсь сравнить значения ячеек между 2 листами (Sheet1 & Sheet2), чтобы увидеть, совпадают ли они, и если они совпадают, переместите соответствующие значения в Sheet1 в ранее существующий список (Sheet3) и удалите значения в Sheet1 впоследствии.

Я использую обратный цикл For В Excel VBA, но все работает до той части, где я начинаю удалять строку с помощью newrange1.EntireRow.Delete.

это вызывает ошибку объекта " 424 " в VBA, и я потратил часы, пытаясь решить эту проблему, я не уверен почему это появляется. Я неправильно выбираю строку? Объект?

был бы признателен, если кто-нибудь может мне точку в правильном направлении.

вот мой код:

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

вот ошибка, которую я получаю:

424 Object Required

7
excel excel-vba vba

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
3

ваш внутренний цикл производит много пошаговой работы, которая лучше выполняется с 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

как отмечает Райан Wildry, ваша исходная проблема заключалась в продолжении цикла и сравнении после удаления строки. Этого можно избежать, добавив Exit For после newrange1.EntireRow.Delete выпрыгнуть из внутренней петли, как только матч был найдено. Я не думаю, что вы должны "сбросить cell1", так как это может испортить итерацию цикла.

5