Find value, cut row, and paste in separate sheet

Move Criteria Rows to Another Worksheet

The Solution (AutoFilter)

• It is assumed that the data is in a table (one row of headers, not necessarily an Excel table), that it is contiguous (no empty rows or columns), and that it starts in cell A1.

• If you only need the first 24 columns you can do one of the following:

  Set srg = Sheet1.Range("A1").CurrentRegion.Resize(, 24)
  Set srg = Sheet1.Range("A1").CurrentRegion.Columns("A:X")
  

Option Explicit

Sub MoveMatchingDataRows()
    
    Const Title As String = "Move Data Rows"
    Const scCol As Long = 4
    Const dCol As Long = 1
    Const Criteria As String = "FD.Matching Gifts FY22"
    
    ' Remove any previous filters.
    If Sheet1.AutoFilterMode Then
        Sheet1.AutoFilterMode = False
    End If
    
    ' Filter.
    Dim srg As Range ' Source Range (Headers and Data)
    Set srg = Sheet1.Range("A1").CurrentRegion
    srg.AutoFilter scCol, Criteria
    
    ' Count the number of matches.
    Dim sdrg As Range ' Source Data Range (Without Headers)
    Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    Dim sdccrg As Range ' Source Data Criteria Column Range
    Set sdccrg = sdrg.Columns(scCol)
    Dim drCount As Long ' Destination Rows Count (Matches Count)
    drCount = Application.Subtotal(103, sdccrg)
    
    ' Move if there are matches.
    
    If drCount > 0 Then ' matches found
        
        Dim sdfrrg As Range ' Source Data Filtered Rows Range
        Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
        Dim dCell As Range ' Destination Cell
        Set dCell = Sheet2.Cells(Sheet2.Rows.Count, dCol).End(xlUp).Offset(1, 0)
        
        With sdfrrg
            
            .Copy dCell
            
            ' Either delete the entire worksheet rows...
            '.EntireColumn.Delete
            
            ' ... or remove filter to prevent...
            Sheet1.AutoFilterMode = False
            ' ... deleting the entire worksheet rows leaving possible data
            ' to the right (after the empty column) intact.
            .Delete xlShiftUp
        
        End With
    
    Else ' no matches
        
        Sheet1.AutoFilterMode = False
   
    End If
        
    ' Inform the user.
    Select Case drCount
    Case 0
        MsgBox "No matches found. No action taken.", vbExclamation, Title
    Case 1
        MsgBox "Found one match.", vbInformation, Title
    Case Else
        MsgBox "Found " & drCount & " matches.", vbInformation, Title
    End Select

End Sub

A Quick Fix (Loop)

• You cannot loop from top to bottom in this way, because if there are consecutive rows containing the criteria, only the first row will be moved to leave the second row in place. You could use a For...Next loop and manipulate the counter variable accordingly but it is slow and just doesn't feel right.
• The problem in the following solution is that since we're looping from bottom to top (For r = CopyLastRow To CopyFirstRow Step -1), the data is copied upside down (it's only 'good' for deleting) and that it is not efficient (slow).
• An improvement would be to use Application.Union i.e. to loop from top to bottom, combining each matching cell into a range and then copying and deleting this range in one go (per action). I would have written it, but there are many examples on SO (e.g. Union, GetCombinedRange). Anyways, AutoFilter provides the most efficient way.

Sub CopyMatching()

    Const CopyFirstRow As Long = 2

    Dim CopyLastRow As Long
    CopyLastRow = Sheet1.Range("D" & Sheet1.Rows.Count).End(xlUp).Row
    
    Dim PasteLastRow As Long
    PasteLastRow = Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row
    Dim PasteCell As Range
    Set PasteCell = Sheet2.Range("A" & PasteLastRow).Offset(1, 0)
    
    Application.ScreenUpdating = False
    
    Dim CopyCell As Range
    Dim r As Long
    
    For r = CopyLastRow To CopyFirstRow Step -1
        Set CopyCell = Sheet1.Range("D" & r)
        If CopyCell.Value = "FD.Matching Gifts FY22" Then
            With CopyCell.Offset(0, -3).Resize(1, 24)
                .Copy PasteCell
                .Delete
            End With
            Set PasteCell = PasteCell.Offset(1, 0)
        End If
    Next r

    Application.ScreenUpdating = True

End Sub