Copy and Insert Rows based on value in column R

[Dgoldsm0]

Hi,

I am very new to VBA and am after a solution that will execute quickly that enables a loop through the values in column R (if that's the quickest way to do it?) and if the value is greater than 1 it will copy the entire row and insert it above the current row. Furthermore I would like the value in the newly inserted row to then equal 1. (There are 3344 rows with data in the spreadsheet and it starts with data in A2)

This is what I currently have from searching online however I need the rows to insert above the current row that meets the condition not at the next empty row

Public Sub CopyRows()
Sheets("WAProducts").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column R
ThisValue = Cells(x, 18).Value
If ThisValue > 1 Then
Cells(x, 1).Resize(1, 22).Copy
Sheets("WAProducts").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("WAProducts").Select
Cells(NextRow, 18) = " "
Cells(NextRow, 18) = 1
End If
Next x
End Sub

I should also mention I have a formula in column R so that's why in "my code" I have set the cell to empty first and then 1 so the formula does not overwrite the 1

I appreciate any help that you can give and really looking forward to what you come up with :) Thankyou

[offthelip]

try this:

note I have reversed the order of the processing to ensure that as you insert rows you don't have to recalculate where to end the loop
Public Sub CopyRows()
'Sheets("WAProducts").Select
Sheets("Sheet1").Select


' Find the last row of data
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = Finalrow To 2 Step -1
' Decide if to copy based on column R
ThisValue = Cells(x, 18).Value
If ThisValue > 1 Then
Cells(x, 1).Resize(1, 22).Copy
Rows(x).Insert shift:=xlShiftDown
Cells(x, 1).Select
ActiveSheet.Paste
Cells(x, 18) = " "
Cells(x, 18) = 1
End If
Next x
End Sub



I forgot to say can you use code tags when you insert VBa it makes it much easier to read

[Dgoldsm0]

Thankyou very much the code worked, the only problem is it takes over 2 minutes to execute (I clicked off it and started to not respond but I had tested it with only 20 lines of data by pasting into a separate session of excel and it worked straight away), do you have any suggestions that could be added to enable it to process this amount of data a wee bit faster? Thankyou again offthelip you were super quick on the error in the code, what a brain you have on your shoulders! :)

[offthelip]

It is the shift down that really takes the time, particularly if the spreadsheet is large, also copying and pasting individual cells take a time for each one. I didn't change your basic code which is not very efficient.