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

[Dgoldsm0]

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 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]

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]

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]

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