Dgoldsm0
09-30-2016, 01:09 AM
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
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