VBA - Moving Rows to different row based on criteria is only working one at a time

Question

I have created an excel VBA script to move rows to different sheets based on the status of the item in that row. However, when I run the code it does not always move all the items at once if there is more than one status update. I would like to make it so that if multiple rows have status updates, when I run the script they all move at once. I'm assuming it has something to do with the "if statements" but I am drawing a blank on any other ways to do it. Any help is greatly appreciated. Thanks!

Below is my code:

Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
A = Worksheets("Tracking").UsedRange.Rows.Count
B = Worksheets("In Progress").UsedRange.Rows.Count
C = Worksheets("Completed").UsedRange.Rows.Count
D = Worksheets("Removed").UsedRange.Rows.Count
If B = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("In Progress").UsedRange) = 0 Then B = 0
ElseIf C = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then C = 0
ElseIf D = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Removed").UsedRange) = 0 Then D = 0
    End If
Set xRg = Worksheets("Tracking").Range("S1:S" & A)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
    If CStr(xCell.Value) = "In Progress" Then
        xCell.EntireRow.Copy Destination:=Worksheets("In Progress").Range("A" & B + 1)
        xCell.EntireRow.Delete
        B = B + 1
    ElseIf CStr(xCell.Value) = "Completed" Then
        xCell.EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & C + 1)
        xCell.EntireRow.Delete
        C = C + 1
    ElseIf CStr(xCell.Value) = "Remove" Then
        xCell.EntireRow.Copy Destination:=Worksheets("Removed").Range("A" & D + 1)
        xCell.EntireRow.Delete
        D = D + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

Answer 1

edited to add selected rows deletion

just be sure to have a header row in your "Tracking" worksheet and then AutoFilter() will make your life as easy as the following code:

Option Explicit

Sub MoveRows()
    Application.ScreenUpdating = False

    With Worksheets("Tracking")
        With .Range("S1", .Cells(.Rows.count, "S").End(xlUp))
            FilterAndCopy .Cells, "In Progress"
            FilterAndCopy .Cells, "Completed"
            FilterAndCopy .Cells, "Remove"
        End With
    End With

    Application.ScreenUpdating = True
End Sub

Sub FilterAndCopy(rng As Range, filterStrng As String)
    With rng '<--| reference passed 'rng' range
        .AutoFilter Field:=1, Criteria1:=filterStrng '<--| filter its 1st column with passed 'filterStrng'
        If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell filtered other than header
            With .Resize(.Rows.count).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow
                .Copy Destination:=Worksheets(filterStrng).Cells(Rows.count, "A").End(xlUp).Offset(1)  '<--|copy filtered cells (skipping headers row) to passed 'filterStrng' named worksheet 1st column from its column A first empty row after last not empty one
                .Delete
            End With
        End If
        .Parent.AutoFilterMode = False
    End With
End Sub