Finding blank cells and moving row - excel

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.

Answer 1

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