Sub MoveToEnd() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xEndRow As Long Dim I As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If lOne: Set xRg = Application.InputBox("Select range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub If xRg.Columns.Count > 1 Or xRg.Areas.Count > 1 Then MsgBox " Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel" GoTo lOne End If xEndRow = xRg.Rows.Count + xRg.Row Application.ScreenUpdating = False For I = xRg.Rows.Count To 1 Step -1 If xRg.Cells(I) = "Done" Then xRg.Cells(I).EntireRow.Cut Rows(xEndRow).Insert Shift:=xlDown End If Next Application.ScreenUpdating = True End Sub
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter