Move based on value VBA

Move Matching Rows

Sub ArchiveCompleteRecords()
    Const PROC_NAME As String = "ArchiveCompleteRecords"
    
    ' Here you choose whether to copy only values for the whole rows (True)
    ' or to copy using the Copy method as you did before and subsequently copy
    ' the value in column 'D' (False).
    Const OK_TO_COPY_VALUES_ONLY As Boolean = False
    
    ' Here you choose whether to delete records (True) or not (False).
    ' The latter is useful while developing and testing the code.
    Const OK_TO_DELETE_RECORDS As Boolean = False
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it isn't, reference it by its name or use 'ActiveWorkbook' instead.
    
    ' Reference the source sheet.
    Dim sws As Worksheet: Set sws = wb.Sheets("Deliverables")
    
    ' Reference the source range.
    Dim srg As Range
    With sws.UsedRange
        Set srg = sws.Range("A2", .Cells(.Cells.CountLarge))
    End With
    
    ' Retrieve the number of columns (the same for source and destination).
    Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
    
    ' Reference the destination sheet.
    Dim dws As Worksheet: Set dws = wb.Sheets("Complete")
    
    ' Reference the last populated destination row range resized
    ' to the number of columns in the source range.
    Dim drrg As Range
    With dws.UsedRange
        Set drrg = dws.Range("A1").Offset(.Rows.Count - 1) _
            .Resize(, ColumnsCount)
    End With
    
    ' Turn off settings.
    Application.ScreenUpdating = False
    
    ' Declare variables.
    Dim surg As Range, srrg As Range, scell As Range, dRowOffset As Long
    
    ' Loop through the rows of the source range.
    For Each srrg In srg.Rows
        ' Reference the criteria cell.
        Set scell = srrg.Columns("S")
        ' Check if the value matches the criteria.
        If CStr(scell.Value) = "Complete" Then
            ' Adjust the next available destination row.
            dRowOffset = dRowOffset + 1 ' next row
            ' Copy.
            If OK_TO_COPY_VALUES_ONLY Then
                ' Copy values only.
                drrg.Offset(dRowOffset).Value = srrg.Value
            Else
                ' Copy as you did before and copy the value of column 'D'.
                srrg.Copy Destination:=drrg
                drrg.Columns("D").Value = srrg.Columns("D").Value
            End If
            ' Combine the matching rows into a unioned range
            ' to be deleted in one go at the end.
            If surg Is Nothing Then
                Set surg = srrg
            Else
                Set surg = Union(surg, srrg)
            End If
        End If
    Next srrg
    
    ' Delete the archived source rows.
    Dim WereRecordsArchived As Boolean
    If Not surg Is Nothing Then
        If OK_TO_DELETE_RECORDS Then
            surg.Delete Shift:=xlShiftUp
        Else
            MsgBox "You were about to delete the following rows:" & vbLf _
                & Join(Split(surg.Address(0, 0), ","), vbLf), vbInformation, _
                PROC_NAME & " - Test Mode"
            'Debug.Print Join(Split(surg.Address(0, 0), ","), vbLf)
        End If
        WereRecordsArchived = True
    End If
    
    ' Turn on settings.
    Application.ScreenUpdating = True
    
    ' Activate the source sheet (not necessarry!?).
    'sws.Activate
    
    If WereRecordsArchived Then
        MsgBox "Complete records archived.", vbInformation, PROC_NAME
    Else
        MsgBox "The records had already been archived!", _
            vbExclamation, PROC_NAME
    End If

End Sub

Simply copying the row causes formulas (like the one in column D) to re-point to the wrong cells on the destination sheet.

It is the best-practice, production-ready version of your macro.
It avoids Select, handles row deletion correctly, preserves your logic, and locks column D as values before moving the row so formulas never shift.

Sub MoveCompletedProjects()

    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    Dim lastSrcRow As Long
    Dim lastDstRow As Long
    Dim r As Long

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set wsSrc = Worksheets("Deliverables")
    Set wsDst = Worksheets("Complete")

    ' Last used rows
    lastSrcRow = wsSrc.Cells(wsSrc.Rows.Count, "S").End(xlUp).Row
    lastDstRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row

    ' Loop bottom-to-top to safely delete rows
    For r = lastSrcRow To 1 Step -1
        
        If wsSrc.Cells(r, "S").Value = "Complete" Then
            
            ' Lock column D as values BEFORE moving
            wsSrc.Cells(r, "D").Value = wsSrc.Cells(r, "D").Value
            
            ' Copy row to destination
            wsSrc.Rows(r).Copy Destination:=wsDst.Rows(lastDstRow + 1)
            
            ' Delete source row
            wsSrc.Rows(r).Delete
            
            lastDstRow = lastDstRow + 1
        End If
        
    Next r

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

No .Select or .Activate

Bottom-to-top loop

Formula-safe transfer

Performance optimized

Explicit worksheet references

My answers are voluntary and without guarantee!

Hope this will help you.

Was the answer useful? Mark as best response and like it!

This will help all forum participants.