VBA Move entire row to the bottom of sheet based on Cell Value

[unknownymous]

Hi Gurus,

I have 2 sheets and wanted to move the entire row at the bottom if the cell value is "1".

Sheet 1 - Look for the value of "1" in Column C then move to bottom
Sheet 2 - Look for the value of "1" in Column E then move to bottom

I found this code but is it possible to fix the code and set the column as stated above. The range could be based on Column A

Source : How to move entire row to the bottom of active sheet based on cell value in Excel?

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

= = =

Appreciate the help.

 

[Michael M]

A bit clunky, but I don't have EXcel at the moment
I'm sure someone will jump in and shorten it

Sub MoveToEnd()
Dim lr As Long, r As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 1 Step -1
If .Cells(r, 3) = 1 Then
    .Rows(r).Cut
    .Rows(lr + 1).Insert
lr = .Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
End With
With Sheets("Sheet2")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 1 Step -1
If .Cells(r, 5) = 1 Then
    .Rows(r).Cut
    .Rows(lr + 1).Insert
lr = .Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
End With
Application.ScreenUpdating = True
End Sub

 

[unknownymous]

A bit clunky, but I don't have EXcel at the moment
I'm sure someone will jump in and shorten it

Sub MoveToEnd()
Dim lr As Long, r As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 1 Step -1
If .Cells(r, 3) = 1 Then
    .Rows(r).Cut
    .Rows(lr + 1).Insert
lr = .Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
End With
With Sheets("Sheet2")
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 1 Step -1
If .Cells(r, 5) = 1 Then
    .Rows(r).Cut
    .Rows(lr + 1).Insert
lr = .Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
End With
Application.ScreenUpdating = True
End Sub

Thanks Michael. It's working but taking some minutes since I have a long list.

 

[Peter_SSs]

Try these. Copy both codes into a module and run the 'MoveRowsToBottom' procedure.
I have assumed that the sheets have a header row in row 1.

Sub MoveRowsToBottom()
  MoveRowsOnSheet Sheets("Sheet1"), "C", 1
  MoveRowsOnSheet Sheets("Sheet2"), "A", 1
End Sub

Sub MoveRowsOnSheet(ws As Worksheet, Col As String, Val As Variant)
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  With ws
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range(Col & 2, .Range(Col & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 1) <> Val Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k < UBound(b) Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Columns(nc).ClearContents
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

 

[unknownymous]

This o

Try these. Copy both codes into a module and run the 'MoveRowsToBottom' procedure.
I have assumed that the sheets have a header row in row 1.

Sub MoveRowsToBottom()
  MoveRows Sheets("Sheet1"), "C", 1
  MoveRows Sheets("Sheet2"), "A", 1
End Sub

Sub MoveRowsOnSheet(ws As Worksheet, Col As String, Val As Variant)
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  With ws
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range(Col & 2, .Range(Col & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 1) <> Val Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k < UBound(b) Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Columns(nc).ClearContents
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub

Thanks Peter. I just tweak this part since I'm getting an error initially.

Sub MoveRowsToBottom()
MoveRowsOnSheet Sheets("Sheet1"), "C", 1
MoveRowsOnSheet Sheets("Sheet2"), "A", 1
End Sub

Massive thanks for the help.

 

[Peter_SSs]

I just tweak this part since I'm getting an error initially.

Yes, I decided to change the name of the second procedure and forgot to update it in the first. I have fixed it in my post so it will be clearer for future readers.