Как остановить функцию «Найти, если потом» от обрезки / удаления / вставки строк, которые уже вырезаны / удалены / вставлены в тот же лист

Question

Я адаптировал приведенный ниже код так, чтобы целые строки вырезались и вставлялись в более низкое место на одном и том же листе на основе определенного значения в столбце. Строки вставляются не в последнюю строку, а в несколько пустых строк между строками, в которых есть данные. Допустим, у меня есть 12 строк, которые нужно скопировать и вставить в 12 пустых строк между данными. Приведенный ниже код сначала переместит строки в 12 пустых строк, но затем продолжит перемещать около 6 строк, которые уже были перемещены в место в конце всех строк. Как сделать так, чтобы код останавливался после перемещения 12 строк?

Sub MoveLS()

    Dim i As Variant
    Dim endrow As Integer
    Dim Version3 As Worksheet

    Set Version3 = ActiveWorkbook.Sheets("Version 3")

    endrow = Version3.Range("A1").End(xlDown).Offset(1, 0).Row

    For i = 2 To endrow
        If Version3.Cells(i, "AVI").Value = "3. NOT ON LIST" Then
            Version3.Cells(i, "AVI").EntireRow.Cut Destination:=Version3.Range("A1").End(xlDown).Offset(1, 0)
            Version3.Cells(i, "AVI").EntireRow.Delete
        End If
    Next

End Sub

Answer 1

Вот один из подходов: удерживайте удаление строк, пока не закончите цикл.

Sub MoveLS()

    Dim i As Variant
    Dim endrow As Integer
    Dim Version3 As Worksheet
    Dim rngDel As Range

    Set Version3 = ActiveWorkbook.Sheets("Version 3")

    endrow = Version3.Range("A1").End(xlDown).Row 'removed the Offset(1, 0)
    For i = 2 To endrow
        If Version3.Cells(i, "AVI").Value = "3. NOT ON LIST" Then

            Version3.Cells(i, "AVI").EntireRow.Cut _
                    Destination:=Version3.Range("A1").End(xlDown).Offset(1, 0)
            'add a dummy value so the next xlDown doesn't stop here
            Version3.Cells(i, "A").Value = "XXX" 

            'build range to delete later
            If rngDel Is Nothing Then
                Set rngDel = Version3.Cells(i, "AVI")
            Else
                Set rngDel = Application.Union(rngDel, Version3.Cells(i, "AVI"))
            End If
        End If
    Next

    'delete any cleared rows
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete

End Sub