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