Copy Paste all Rows where Range cell value > 0

[terrycr]

I am trying to Copy all Rows (Sheet "Payouts") where Range cell value > 0, and paste to Sheet "PaymentRecords".
Right now it only copies the last row that is selected and pastes it. Where there is a value in Column B (starting at B10 and rest of column), I want to select those rows to paste to other sheet. See the image below... I would want to copy rows 11 & 14... right now it will only copy row 14.


Here is my current code:

Sub PayoutsRecordPayments()

Dim rangeB As Range
Set rangeB = Sheets("Payouts").Range("B10:B6800")
lastRow = Sheets("Payouts").Range("B" & Rows.Count).End(xlUp).Row
PRlastRow = Sheets("PaymentRecords").Range("B" & Rows.Count).End(xlUp).Row
'For Each cell In Sheets("Payouts").Range("b10:b6500" & lastRow)
For Each cell In rangeB
If cell.value > 0 Then

With Sheets("Payouts")
cell.EntireRow.Copy
End With

' This finds the last row +1 on PaymentRecords and pastes there

Sheets("PaymentRecords").Range("A" & PRlastRow + 1).PasteSpecial xlValues


End If

Next

End Sub

 

[Alex Blakenburg]

You are currently not increment the output last row counter so all the rows are copying over the previous one.

Sub PayoutsRecordPayments()

    Dim rangeB As Range
    Dim lastrow As Long, PRlastRow As Long             ' XXX Added
 
    ' XXX Swap these 2 around
    lastrow = Sheets("Payouts").Range("B" & Rows.Count).End(xlUp).Row
    Set rangeB = Sheets("Payouts").Range("B10:B" & lastrow)
   
    PRlastRow = Sheets("PaymentRecords").Range("B" & Rows.Count).End(xlUp).Row
 
    For Each cell In rangeB
        If cell.Value > 0 Then
    
            With Sheets("Payouts")
                cell.EntireRow.Copy
            End With
        
            ' XXX Increment the last row counter
            PRlastRow = PRlastRow + 1
        
            ' This finds the last row +1 on PaymentRecords and pastes there
            Sheets("PaymentRecords").Range("A" & PRlastRow).PasteSpecial xlValues     ' XXX Removed the +1 it is included in incrementing the counter
        
        End If
 
    Next

End Sub

 

[terrycr]

You are currently not increment the output last row counter so all the rows are copying over the previous one.

Sub PayoutsRecordPayments()

    Dim rangeB As Range
    Dim lastrow As Long, PRlastRow As Long             ' XXX Added
 
    ' XXX Swap these 2 around
    lastrow = Sheets("Payouts").Range("B" & Rows.Count).End(xlUp).Row
    Set rangeB = Sheets("Payouts").Range("B10:B" & lastrow)
  
    PRlastRow = Sheets("PaymentRecords").Range("B" & Rows.Count).End(xlUp).Row
 
    For Each cell In rangeB
        If cell.Value > 0 Then
   
            With Sheets("Payouts")
                cell.EntireRow.Copy
            End With
       
            ' XXX Increment the last row counter
            PRlastRow = PRlastRow + 1
       
            ' This finds the last row +1 on PaymentRecords and pastes there
            Sheets("PaymentRecords").Range("A" & PRlastRow).PasteSpecial xlValues     ' XXX Removed the +1 it is included in incrementing the counter
       
        End If
 
    Next

End Sub

Perfect! Thanks so much.

 

[Alex Blakenburg]

You're welcome. Glad I could help.