# Moved rows to another sheet multiple options / looping

#### Sdwd76

##### New Member
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

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

### Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

#### Sdwd76

##### New Member
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

VBA Code:
``````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``````

Last edited by a moderator:

#### Fluff

##### MrExcel MVP, Moderator
VBA Code:
``````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

##### New Member
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

##### MrExcel MVP, Moderator

Yup, you can do it like
VBA Code:
``````   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

##### New Member
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

##### MrExcel MVP, Moderator
As that's a different question, it needs a new thread.

Replies
19
Views
240
Replies
7
Views
364
Replies
4
Views
253
Replies
0
Views
167
Replies
4
Views
232

1,136,794
Messages
5,677,779
Members
419,720
Latest member
kurman

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back