VBA Copy entire row if cell matches a value for entire sheet

Question

I'm trying to have an update button where it checks the cells in column H for values "not started" or "closed" and cut/paste these cells to the corresponding sheet. The code I currently have doesn't treat every cell and only copies one row to each sheet.

Screenshot:

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim lastRow As Long
    Dim Cell As Range

'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

'Select Entire Row
    Selection.EntireRow.Select

'Move row to destination sheet & Delete source row
    lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
    lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
    lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row

    With sht2
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If Cell.Value = "Not started" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
            .Rows(Cell.Row).Delete

        ElseIf Cell.Value = "Closed" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
            .Rows(Cell.Row).Delete

        End If
     Next Cell

    End With

    MsgBox "Update Done!"

End Sub

Answer 1

Normally when you need to delete the rows based on a criteria, you should use a counter variable and loop through the cells in the reverse order .

But if you are looping through cells using range/cell objects, you should not delete the row just after copying it to another sheet. Instead, you should declare a range variable and store the address of all the cells which qualify for the row delete criteria and delete them all at once in the end.

In this scenario, the Autofilter is an ideal candidate to use.

Please try the tweaked version of your original code.

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
    Dim Cell As Range
    Dim RngToDelete As Range

    Application.ScreenUpdating = False
'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

'Select Entire Row
    'Selection.EntireRow.Select

'Move row to destination sheet & Delete source row
    lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
    lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
    lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row

    With sht2
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If Cell.Value = "Not started" Then
            If RngToDelete Is Nothing Then
                Set RngToDelete = Cell
            Else
                Set RngToDelete = Union(RngToDelete, Cell)
            End If
            lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
            '.Rows(Cell.Row).Delete

        ElseIf Cell.Value = "Closed" Then
            If RngToDelete Is Nothing Then
                Set RngToDelete = Cell
            Else
                Set RngToDelete = Union(RngToDelete, Cell)
            End If
            lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
            '.Rows(Cell.Row).Delete

        End If
     Next Cell

    End With

    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
    Application.CutCopyMode = 0
    Application.ScreenUpdating = True
    MsgBox "Update Done!"

End Sub

Answer 2

Edit: as per comment corrected sht to sht2

when deleting items from a Collection (like rows in a Range is) you should proceed from bottom to top and avoid both skipping items and processing nonexistent ones

moreover your code didn't update lastRow(n) of "tagret" sheets

do consider following code (untested, but commented)

Private Sub CommandButton1_Click()
'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht3 As Worksheet
    Dim iRow As Long

'Set variables
    Set sht1 = Sheets("To DO")
    Set sht2 = Sheets("Ongoing")
    Set sht3 = Sheets("Done")

    With sht2
        With Range("H1", .Cells(.Rows.Count, "H").End(xlUp)) 'reference its column H from row 1 down to last not empty one
            iRow = .Rows.Count 'initialize row index from the bottom
            Do
                With .Cells(iRow, 1) 'reference referenced range cell in its current row
                    Select Case .Value
                        Case "Not started"
                            .Rows(iRow).Copy Destination:=sht1.Cells(sht1.Rows.Count, "A").End(xlUp)
                            .Rows(iRow).Delete

                        Case "Closed"
                            .Rows(iRow).Copy Destination:=sht3.Cells(sht3.Rows.Count, "A").End(xlUp)
                            .Rows(iRow).Delete
                    End Select
                End With
                iRow = iRow - 1
             Loop While iRow >= 1
        End With
    End With

    MsgBox "Update Done!"

End Sub