Macro to Copy and Paste if condition is met

[olevia]

Hello Forum,

I need a macro that would look at spreadsheet called Tool Test Tab Review column J7 to J infinity and if column P7 to P infinity is < column J7 to J infinity the macro would copy the row starting a A7:B7:C7:D7:E7:F7:G7:J7 Overpayment Tab cell H7: I7: and L7 and paste it to Data Tab starting at row A18 and move to next row. I also need the boarders added for each row pasted to the Data tab. Important note after a row is pasted the yellow row must remain being pushed down each time a new row is added when the condition is met.
Please see attachment of the spread sheet named Tool Test. Thank you for your help in advance.

[daffodil11]

Sub KittenExplosion()

Dim wsRev As Worksheet: Set wsRev = Sheets("Review")
Dim wsOver As Worksheet: Set wsOver = Sheets("Overpayment Summary")
Dim wsData As Worksheet: Set wsData = Sheets("Data")
Dim lngLastReview As Long: lngLastReview = wsRev.Range("J6").End(xlDown).Row
Dim i As Long

For i = 7 To lngLastReview
    If wsRev.Cells(i, "P") < wsRev.Cells(i, "J") Then
        wsOver.Range(wsOver.Cells(i, 1), wsOver.Cells(i, 10)).Copy
        wsData.Range("A16").End(xlDown).Offset(1).PasteSpecial xlPasteValues
        wsData.Range("A16").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown
        With wsData.Range("A" & ActiveCell.Row + 1, "M" & ActiveCell.Row + 1)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        End With
    End If
Next

End Sub

[olevia]

Hi daffodil11

The Macro works great, but it only did one row on the Review Tab. When I include information on the next row on the Review Tab that information is not copied and pasted over to the Data sheet. Feel free to add any information on the next row on the Review Tab to see for your self. I truly appreciate your help and thank you again.

[daffodil11]

I see. I've modified the code to use a hardcoded start at 17, and cycle upwards to avoid the error.

Sub KittenExplosion()

Dim wsRev As Worksheet: Set wsRev = Sheets("Review")
Dim wsOver As Worksheet: Set wsOver = Sheets("Overpayment Summary")
Dim wsData As Worksheet: Set wsData = Sheets("Data")
Dim lngLastReview As Long: lngLastReview = wsRev.Range("J6").End(xlDown).Row
Dim i As Long, x As Long: x = 18

For i = 7 To lngLastReview
    If wsRev.Cells(i, "P") < wsRev.Cells(i, "J") Then
        wsOver.Range(wsOver.Cells(i, 1), wsOver.Cells(i, 10)).Copy
        wsData.Range("A" & x).PasteSpecial xlPasteValues
        wsData.Range("A" & x + 1).EntireRow.Insert Shift:=xlDown
        With wsData.Range("A" & x + 1, "M" & x + 1)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        End With
        x = x + 1
    End If
Next

End Sub