Rows where the first cell is blank, not copying to another sheet-CodePudding

The code I'm using copies rows successfully to another sheet based on a certain selected values in a dropdown list in Column B. However, if any cell in the first column (A) is blank, even if that certain value in column B is 'true' it will not copy over.

Would anyone here know how to successfully copy the row over regardless of the first cell in that row being blank? The code I'm using is below.

Thanks :)

Sub ClearandCopyActiveFeedback()

Sheet3.Range("A3:Z2000").ClearContents

Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range

Set StatusCol = Sheet2.Range("B3:B2000")

For Each Status In StatusCol

    Set PasteCell = Sheet3.Range("A1").End(xlDown).Offset(1, 0)
    
If Status = "Active" Then Status.EntireRow.Copy PasteCell

Next Status
End Sub

CodePudding user response：

Move PasteCell down after each copy.

Option Explicit
Sub ClearandCopyActiveFeedback()

    Const MAXROW = 2000
    Dim PasteCell As Range, cell As Range
    Dim rowLast As Long, n As Long

    With Sheet3
        .Range("A3:Z" & MAXROW).ClearContents
        Set PasteCell = .Range("A3")
    End With

    With Sheet2
        rowLast = .Range("B" & MAXROW).End(xlUp).Row
        For Each cell In .Range("B3:B" & rowLast)
            If cell = "Active" Then
                cell.EntireRow.Copy PasteCell
                Set PasteCell = PasteCell.Offset(1)
                n = n   1
            End If
        Next
    End With
    MsgBox n & " rows copied"
End Sub