Moved rows to another sheet multiple options / looping

[Sdwd76]

Hi all

Trying to create a button so it will move rows to another sheet. I have got it to work but only in VB if i run it via a button or run macro it does not work??
I have date in Sheet 1 - if column F has a 1 in this then move the row to Sheet 2.

Various issues.

This works but I have to run this multiple times for all rows where there is a 1 in column F to be moved. (Need a loop to fix this?)
Secondly I would also like it to look for the word REJECT in column X and if this is there then move the entire row.

Please any help I would be grateful. Also again having a working button to do this rather than going into run macro etc

Thanks in advance.



Private Sub CommandButton1_DblClick

Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Survey QA").UsedRange.Rows.Count
B = Worksheets("Move").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Move").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Survey QA").Range("F1:F" & A)
On Error Resume Next
Application.ScreenUpdating = False
For f = 1 To xRg.Count
If CStr(xRg(f).Value) = "1" Then
xRg(f).EntireRow.Copy Destination:=Worksheets("Move").Range("a" & B + 1)
xRg(f).EntireRow.Delete
If CStr(xRg(f).Value) = "1" Then
f = f - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True



End Sub

 

[Sdwd76]

some progress I have used this macro and it seems to work as required. No more running it multiple times. Does any one know how i can add if column X has various words in this then these rows will be moved as well? Again 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

 

[Fluff]

How about

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") = True
   ElseIf rs1.Cells(r, "X").Value = "REJECT" Then
      rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
      rs1.Cells(r, "A") = True
   End If

Next r


On Error Resume Next
    rs1.Range("A1:A" & Lr).SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
On Error GoTo 0

Application.ScreenUpdating = True

End Sub

 

[Sdwd76]

Brilliant thank you so much works as required!!!!

Another question on the back of this whilst you have been so helpful - if on a row I wanted to check two different cells and if they both had a certain word then move?

so in col T - we look for the word ROOF and in Z we have FELT then if this matches we move the row. Could i use an "and" statment?

 

[Fluff]

Yup, you can do it like

   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") = True
   ElseIf rs1.Cells(r, "X").Value = "REJECT" Then
      rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
      rs1.Cells(r, "A") = True
   ElseIf rs1.Cells(r, "T").Value = "ROOF" And rs1.Cells(r, "Z").Value = "FELT" Then
      rs1.Cells(r, "A").EntireRow.Copy Destination:=rs2.Range("A" & Rows.Count).End(xlUp).Offset(1)
      rs1.Cells(r, "A") = True
   End If

 

[Sdwd76]

Fluff you are a legend thanks!!

one more if we identify a row with say in row C it has broken.
We want to move this to another sheet called Damage

However we would only one certain cells copying not the whole row? is this possible. Or easier to copy the row and do a v look up to fill in the fields we need?

 

[Fluff]

As that's a different question, it needs a new thread.