Copy last 3 rows excluding the rows for which there is a 0 in column C

Question

I want to duplicate the final three rows from A to AD, excluding those that have a "0" in column "C," from the last row in another file and sheet. I want there to always be three copied rows. The code below causes me trouble because it always duplicates only one row at the end.

Sub AB ()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim numCopied As Long
    Dim baseWB As Workbook, baseWS As Worksheet
    Dim spWB As Workbook, spWS As Worksheet

    Set baseWB = ThisWorkbook
    Set baseWS = ActiveSheet

    lastRow = spWS.Cells(spWS.Rows.Count, "D").End(xlUp).Row

    numCopied = 0
    For i = lastRow To lastRow - 8 Step -1
        ' Sprawdź, czy w kolumnie C jest 0
        If spWS.Cells(i, "C").Value <> 0 Then
            spWS.Range(spWS.Cells(i, "A"), spWS.Cells(i, "AD")).Copy
            numCopied = numCopied + 1
        End If
        If numCopied = 3 Then
            Exit For
        End If
    Next i


    baseWB.Sheets("Sheet1").Range("E5").PasteSpecial xlPasteValues
    spWB.Close SaveChanges:=False
   
 
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Answer 1

The copy inside the loop is overwriting the previous copy. They are not additive unless you use Union.

Option Explicit
Sub AB()

    Dim spWB As Workbook, spWS As Worksheet
    Dim baseWB As Workbook, baseWS As Worksheet
    Dim rng As Range, rngCopy As Range
    Dim lastRow As Long, i As Long, numCopied As Long
    
    Set baseWB = ThisWorkbook
    Set baseWS = baseWB.Sheets("Sheet1")
    
    ' open workbook to copy from
    Set spWB = Workbooks.Open("Source.xlsx", ReadOnly:=True)
    Set spWS = spWB.Sheets("Sheet1")
    numCopied = 0
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With spWS
    
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        For i = lastRow To 1 Step -1
            ' Sprawdz, czy w kolumnie C jest 0
            If .Cells(i, "C").Value <> 0 Then
                Set rng = .Cells(i, "A").Resize(, 30) ' A:AD
                If rngCopy Is Nothing Then
                    Set rngCopy = rng
                Else
                    Set rngCopy = Union(rng, rngCopy)
                End If
                numCopied = numCopied + 1
            End If
            If numCopied = 3 Then
                Exit For
            End If
        Next i
    End With
    
    ' copy
    If rngCopy Is Nothing Then
        MsgBox "No rows found to copy", vbExclamation
    Else
        rngCopy.Copy
        baseWS.Range("E5").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        MsgBox " Copied : " & rngCopy.Address, vbInformation
       
    End If
    spWB.Close SaveChanges:=False
     
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True