PDA

View Full Version : Copy the entire row if the value in column R is greater than 1 and insert above



Dgoldsm0
10-12-2016, 07:07 PM
Hi,

I am very new to VBA and am after a solution that will execute very quickly that will copy the entire row if the value in column R is greater than 1.

I need it to insert the copied row above the current row and then change the value of the new row (that is greater than 1) to 1 (leaving the copied from row unchanged).

There are 3344 rows with data with formulas in the spread sheet and it starts with data in A2

I have found code that works but it is too slow to execute :bug: I think due to process of checking line by line or another user thinks it is due to the shift down that was being used in the code. Please help if you can thankyou much appreciated

Bob Phillips
10-13-2016, 12:50 AM
It would help if you could post your workbook, gives us data to work on, and perhaps the code that you have so that we can see how to optimise.

Dgoldsm0
10-13-2016, 01:01 AM
Hi xld I actually just came up with a temporary solution, (trying to think outside the box!) while it won't insert the line above it will below if I add in a sort code under my code such as:

Range("A1:W5000").Sort _
Key1:=Range("A1"), Order1:=xlDescending

It eliminates the need to insert as sorting naturally arranges the product codes which is I am looking to arrange next to each other.

The code I was working with is:


Public Sub CopyRows()
'Sheets("WAProducts").Select

Sheets("WAProducts").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


while it worked perfectly for small amounts of data it would crash when trying with 3000 rows.

As such the new code just inserts the new lines at the next available row I believe being faster and then sorts the data:

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
Range("A1:W5000").Sort _
Key1:=Range("A1"), Order1:=xlDescending
End Sub

If you want to have fun with it looking for a different way (and one that inserts it above [and still changes the value of the copied row in column R to 1]) then that would be fab! But if other people need help I have a tiny work around :) Thankyou so much for your response :):):):):)

Bob Phillips
10-13-2016, 01:56 AM
If you can sort it, that is a better way to go as you c an stop when the criteria meeting rows end, but you can rationalise the insert code


Public Sub CopyRows()

Application.screenupdatig = False

With Worksheets("WAProducts")

Finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row

For x = Finalrow To 2 Step -1

If .Cells(x, 18).Value > 1 Then

.Rows(x).Copy
.Rows(x).Insert Shift:=xlShiftDown
.Cells(x, 18) = 1
End If
Next x
End With

Application.ScreenUpdating = True
End Sub