Moved rows to another sheet multiple options / looping

Sdwd76

New Member
Joined
May 17, 2021
Messages
26
Office Version
  1. 365
Platform
  1. Windows
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
 

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
Joined
May 17, 2021
Messages
26
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Jun 12, 2014
Messages
60,131
Office Version
  1. 365
Platform
  1. Windows
How about
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
Joined
May 17, 2021
Messages
26
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Jun 12, 2014
Messages
60,131
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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
 
Solution

Sdwd76

New Member
Joined
May 17, 2021
Messages
26
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Jun 12, 2014
Messages
60,131
Office Version
  1. 365
Platform
  1. Windows
As that's a different question, it needs a new thread.
 

Forum statistics

Threads
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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top