Переместить записи в конец электронной таблицы, если она содержит 0

Question

Я хотел бы переместить всю строку в конец электронной таблицы, если столбец k содержит 0. Код, который у меня есть, работает только с изменением, а не с активацией или, что еще лучше, с помощью кнопки.Как бы я изменил код для работы вне при изменении?

 Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Cells.Count > 1 Then Exit Sub
 Dim rw As Long
 Application.EnableEvents = False
If Not Intersect(Target, Range("K:K")) Is Nothing And LCase(Target) = 0 Then
rw = Target.Row
    Target.EntireRow.Cut Cells(Rows.Count, 1).End(xlUp)(2)
Rows(rw).Delete
End If
Application.EnableEvents = True
End Sub

Answer 1

Я знаю, что у вас есть ответ, но так как вы хотели Sort, этот код работает.

Sub SortMoveRowstolRow()
Dim fRow As Long, lRow As Long

    With Range("A1").CurrentRegion
        .Sort Key1:=Range("K1"), Order1:=xlAscending, Header:=xlNo

        fRow = .Range("K:K").Find(what:=0, after:=.Range("K1"), Lookat:=xlWhole, searchdirection:=xlPrevious).Row
    End With

    Rows(1 & ":" & fRow).EntireRow.Cut Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Rows(1 & ":" & fRow).EntireRow.Delete

End Sub

Answer 2

Попробуйте:

Option Explicit

Sub test()

 Dim Lastrow As Long, i As Long

 With ThisWorkbook.Worksheets("Sheet1")

    Lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row

    For i = Lastrow - 1 To 1 Step -1

        If .Range("K" & i).Value = 0 Then

            Lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row

            .Rows(i).Cut .Rows(Lastrow + 1)

            .Rows(i).EntireRow.Delete

        End If

    Next i

 End With

End Sub