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