Finding blank cells and moving row

Question

I am trying to find people who are missing their street address and moving their row to a separate tab in my sheet.

Sub NEW_NoAddress()

    Const Title As String = "Move Data Rows"
    Const scCol As Long = 6
    Const dCol As Long = 1
    Const Criteria As String = "ISEmpty()"
           
    ' 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 = Sheet10.Cells(Sheet10.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
        
End Sub

I tried "<>", "<> **", " "" ", I think I tried one that had vbStringISNull, (), and other things I came across in Google. I considered going the other direction and keeping the <> to move those who have an address, but I'd rather move the incorrect entries to my exceptions tab.

user_9814069 · Answer

Move Matching Rows

I'm glad you like my code. Unfortunately, it has a big mistake:
```
 drCount = Application.Subtotal(103, sdccrg)
```
which is similar to Excel's ACOUNT which results in 0 when selecting blanks.
I've seen this in a couple of codes and adopted it as valid. Was I in for a surprise.
When you plan on using such a code so intensely, you want to move the changing variables to the arguments section to easily use it many times (see the long procedure below).

You can use the new procedure...

... for your first question like this:

Sub MoveMatchRows()
    MoveMatchingRows Sheet1, 4, "FD.Matching Gifts FY22", Sheet2, 1, False
End Sub

... for yesterday's question like this:

Sub NEW_Move_Stock_InKind_DAF()
    MoveMatchingRows Sheet1, 44, "<>*/*", Sheet8, 1, False
End Sub

... and for today's question like this:

Sub NewNoAddress()
    MoveMatchingRows Sheet1, 6, "=", Sheet10, 1, False
End Sub

I have declared SourceCriteria as variant and added xlFilterValues to be able to use multiple criteria, e.g. Array("1", "2").

The Procedure

Sub MoveMatchingRows( _
        ByVal SourceWorksheet As Worksheet, _
        ByVal SourceColumn As Long, _
        ByVal SourceCriteria As Variant, _
        ByVal DestinationWorksheet As Worksheet, _
        Optional ByVal DestinationColumn As Long = 1, _
        Optional ByVal DoClearPreviousDestinationData As Boolean = False)
    
    Const ProcTitle As String = "Move Matching Rows"
    
    ' Remove any previous filters.
    If SourceWorksheet.AutoFilterMode Then
        SourceWorksheet.AutoFilterMode = False
    End If
    
    ' Filter.
    Dim srg As Range ' Source Range (Headers and Data)
    Set srg = SourceWorksheet.Range("A1").CurrentRegion
    srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
    
    ' Create a reference to the Source Data Range (no headers).
    Dim sdrg As Range
    Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    ' Clear Destination worksheet.
    If DoClearPreviousDestinationData Then ' new data, copies headers
        DestinationWorksheet.Cells.Clear
    End If
    
    ' Attempt to create a reference to the Source Data Filtered Rows Range.
    Dim sdfrrg As Range
    On Error Resume Next
        Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not sdfrrg Is Nothing Then
        
        ' Create a reference to the Destination Cell (also, add headers).
        Dim dCell As Range ' Destination Cell
        Set dCell = DestinationWorksheet.Cells(1, DestinationColumn)
        If IsEmpty(dCell) Then
            srg.Rows(1).Copy dCell
            Set dCell = dCell.Offset(1)
        Else
            Set dCell = DestinationWorksheet.Cells( _
                DestinationWorksheet.Rows.Count, DestinationColumn) _
                .End(xlUp).Offset(1, 0)
        End If
        
        With sdfrrg
            .Copy dCell
            
            ' Either delete the entire worksheet rows...
            '.EntireColumn.Delete
            
            ' ... or remove filter to prevent...
            SourceWorksheet.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
        
        SourceWorksheet.AutoFilterMode = False
   
    End If
        
End Sub

Finding blank cells and moving row

1 Answers

Move Matching Rows