Copy rows from sheet 1 to sheet 2 based on 2 cell values

[Demer]

Hello I'm trying to move a row from sheet 1 "Chapter to Sheet 2 "Complete" using VBA for instance if A3 = "Cash" and L3 = "Refund" cut copy and paste entire row to Sheet 2 "Complete" and search the other rows if both criteria's are met then cut copy and paste entire row to Sheet 2 "Complete" otherwise don't move the rows. I cant figure this out any help would be much appreciated.

 

[rpaulson]

try this on a copy of your file.

Sub move_it()

Application.ScreenUpdating = False

Dim rs1 As Worksheet, rs2 As Worksheet
Set rs1 = Sheets("Chapter")
Set rs2 = Sheets("Complete")

lr = rs1.Range("A" & Rows.Count).End(xlUp).Row

For r = 1 To lr

If rs1.Cells(r, "A") = "Cash" And rs1.Cells(r, "L") = "Refund" Then
    rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
    rs1.Cells(r, "A") = "DELETE ME"
End If

Next r


On Error Resume Next
    With rs1.Range("A1:A" & lr)
        .Replace "DELETE ME", False, xlWhole
        .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
    End With
On Error GoTo 0

Application.ScreenUpdating = True

End Sub

hth,
Ross

 

[Demer]

Application.ScreenUpdating = False Dim rs1 As Worksheet, rs2 As Worksheet Set rs1 = Sheets("Chapter") Set rs2 = Sheets("Complete") lr = rs1.Range("A" & Rows.Count).End(xlUp).Row For r = 1 To lr If rs1.Cells(r, "A") = "Cash" And rs1.Cells(r, "L") = "Refund" Then rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1) rs1.Cells(r, "A") = "DELETE ME" End If Next r On Error Resume Next With rs1.Range("A1:A" & lr) .Replace "DELETE ME", False, xlWhole .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete End With On Error GoTo 0 Application.ScreenUpdating = True

Thank you very much. This works great I just replaced the delete me with "A" to keep the information in that column

 

[Sdwd76]

Hi how would you move rows if you had either word ?

for example you have row 3 / Col F with Cash and have row 4 / col W with Refund? (bearing in mind other rows may have both words)
Can you move both these rows? Also a loop would be useful where the number of rows is loads. to prevent manual verification checks

 

[Sdwd76]

I have amended the code below to check col F which may have a 1. Now i also have other columns with other values which require moving to Sheet 2. I would like some help one moving rows which have various selections. Like col F has a 1 then move row. Col W has a 3 then move rove, col X has a Tree then move row.

Thanks in advance




Sub move_1s()

Application.ScreenUpdating = False

Dim rs1 As Worksheet, rs2 As Worksheet
Set rs1 = Sheets("sheet1")
Set rs2 = Sheets("Sheet2")

lr = rs1.Range("A" & Rows.Count).End(xlUp).Row

For r = 1 To lr


If rs1.Cells(r, "F") = "1" Then
rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
rs1.Cells(r, "A") = "DELETE ME"


End If

Next r


On Error Resume Next
With rs1.Range("A1:A" & lr)
.Replace "DELETE ME", False, xlWhole
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
On Error GoTo 0

Application.ScreenUpdating = True

End Sub