Fastest way to delete records on excel file based on value in another excel file

Following from my comment above. This ran in ~20sec for me (150k rows of data, 5k random values to be deleted)

EDIT: refactored a bit...

Sub DeleteMatches()
    
    Dim dict As Object, arr, n As Long, t
    Dim col As New Collection
    
    'create some sample data
    With Sheet1.[A2:A150000]
        .Formula = "=""Val_"" & TEXT(ROW()-1,""00000000"")"
        .Value = .Value
    End With
    
    t = Timer
    
    'load the ids to be deleted
    'tested with 5k rows of `="Val_" & TEXT(RANDBETWEEN(1,150000),"00000000")`
    Set dict = UniquesFromColumn(Sheet2.Range("A2"))
    Debug.Print "Loaded Ids: " & Timer - t
    
    'load the sheet1 id column into an array and scan through it,
    '  collecting any matched rows in the Collection
    arr = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp)).Value
    For n = 2 To UBound(arr, 1) 'skip header row if present
        If dict.exists(arr(n, 1)) Then col.Add Sheet1.Cells(n, 1)
    Next n
    Debug.Print "Scanned sheet1 for matches: " & Timer - t
    
    DeleteRows col 'delete the collected rows
    Debug.Print "Deleted " & col.Count & " rows: " & Timer - t
        
End Sub

'return a dictionary of unique values from a column, starting at `startCell`
Function UniquesFromColumn(startCell As Range) As Object
    Dim dict As Object, arr, n As Long, v
    Set dict = CreateObject("scripting.dictionary")
    With startCell.Parent
        arr = .Range(startCell, _
                     .Cells(.Rows.Count, startCell.Column).End(xlUp)).Value
    End With
    For n = 1 To UBound(arr)
        v = arr(n, 1)
        If Len(v) > 0 Then dict(v) = dict(v) + 1
    Next n
    Set UniquesFromColumn = dict
End Function

'delete all rows based on a collection of cells
Sub DeleteRows(col As Collection)
    Dim rng As Range, n As Long, i As Long
    If col.Count = 0 Then Exit Sub
    'loop over the cells in the collection, building ranges for deletion
    For n = col.Count To 1 Step -1
        If rng Is Nothing Then
            Set rng = col(n)
            i = 1
        Else
            Set rng = Application.Union(rng, col(n))
            i = i + 1
            If i > 200 Then 'union gets slow after a point, so delete and reset
                rng.EntireRow.Delete
                Set rng = Nothing
            End If
        End If
    Next n
    If Not rng Is Nothing Then rng.EntireRow.Delete 'any last rows?
End Sub

Let Excel do all the dirty work using native features.

Logic:

1. Use Remove duplicates to get unique entries from Sheet1
2. Store the above data in an array
3. Store Col G from 2nd File in an array
4. Search 1st array in 2nd array and if found replace value by say "DELME"
5. Write the 2nd array back to the worksheet
6. Autofilter column G on "DELME" and delete all rows in 1 go.

Test Conditions I used

The total number of unique IDs in File A and the number of these IDs in File B will always influence the time taken by the code.

The other thing that will influence the time taken by the code is your hardware specs.

I test the below code on

1. ★ CPU ★ Ryzen 5 5800X
2. ★ GPU ★ NVIDIA GeForce RTX 3080 TI Founder Edition
3. ★ RAM ★ G. Skill Trident Z RGB 32GB 3600MHz

See what time does this code give against your data?

File A: 6000 records out of which there are 2500 unique values.

File B: 150000 records which has 20830 duplicates values to be removed.

To do a stess test, I used these 2 files.

Sample Test Files

Code:

Here is the code that I tested

Option Explicit

'~~> This is the 2nd file. Change as applicable
Private Const fileA As String = "C:\Users\routs\Desktop\Delete Me Later\FileA.xlsx"
'~~> This is the 1st file. Change as applicable
Private Const fileB As String = "C:\Users\routs\Desktop\Delete Me Later\FileB.xlsx"

Sub Sample()
    Debug.Print Now
    
    Dim wbA As Workbook
    Dim wsA As Worksheet
    
    Set wbA = Workbooks.Open(fileA)
    
    '~~> This is the relevant sheet
    Set wsA = wbA.Sheets("Sheet1")
    
    Dim lRow As Long
    Dim lCol As Long
    Dim arA As Variant
    
    With wsA
        '~~> Remove any filters
        .AutoFilterMode = False
        
        '~~> Find last row and last column
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lRow = .Range("H" & .Rows.Count).End(xlUp).Row
    
        '~~> Use Excel remove duplicates to delete duplicates
        .Range("A1:" & Split(.Cells(, lCol).Address, "$")(1) & lRow).RemoveDuplicates Columns:=8, Header:=xlYes
    
        '~~> Find the next last row
        lRow = .Range("H" & .Rows.Count).End(xlUp).Row
    
        '~~> Store the data in an array
        arA = .Range("H2:H" & lRow).Value2
    End With
    
    Debug.Print "ID Array has " & lRow & " items"
    
    wbA.Close (False)
    
    Dim wbB As Workbook
    Dim wsB As Worksheet
    
    Set wbB = Workbooks.Open(fileB)
    
    '~~> This is the relevant sheet
    Set wsB = wbB.Sheets("Sheet1")
    
    Dim arB As Variant
    Dim lastCol As String
    Dim oldRow As Long, newRow As Long
    
    With wsB
        '~~> Remove any filters
        .AutoFilterMode = False
            
        '~~> Find last row and last column
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastCol = Split(.Cells(, lCol).Address, "$")(1)
        
        lRow = .Range("G" & .Rows.Count).End(xlUp).Row
        oldRow = lRow
        
        Debug.Print "Main Array has " & lRow & " items"
    
        '~~> Store the data in an array
        arB = .Range("G2:G" & lRow).Value2
    End With
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    For i = LBound(arA) To UBound(arA)
        For j = LBound(arB) To UBound(arB)
            If arB(j, 1) = arA(i, 1) Then arB(j, 1) = "DELME"
        Next j
    Next i
    
    Dim Rng As Range
    
    With wsB
        .Range("G2").Resize(UBound(arB), 1).value = arB
        
        Set Rng = .Range("A1:" & lastCol & lRow)
        
        With Rng
            '~~> Filter, offset(to exclude headers) and delete visible rows
            With Rng
              .AutoFilter Field:=7, Criteria1:="DELME"
              .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End With
        End With
        
        '~~> Remove any filters
        .AutoFilterMode = False
        
        lRow = .Range("G" & .Rows.Count).End(xlUp).Row
        newRow = lRow
        
        Debug.Print "Total " & (oldRow - newRow) & " items were removed."
    End With
    
    Debug.Print Now
End Sub

Output

The code took 58 seconds on this particular test data.

08-12-2021 13:16:51 
ID Array has 2500 items
Main Array has 150000 items
Total 20830 items were removed.
08-12-2021 13:17:49 

Delete Matching Rows

Efficiency

• Using a sample of 20,000 rows in the source (read unique) and 200,000 records in the destination (delete matches) and 20 columns in both worksheets, this solution used between 5 and 15 seconds for 7167 unique 5-char strings and 85,036 deleted rows.

Module1

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a column of a worksheet, compares the value of each cell
'               with all values in a column of a worksheet in another workbook.
'               If there is a match, the entire row of the first mentioned
'               cell is deleted.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:
' DeleteMatchingRows
'     DictUniqueColumnFromThisWorkbook or DictUniqueColumnFromClosedWorkbook
'         RefColumn
'         GetColumnRange
'         DictUniqueColumn
'     RefTableRangeInThisWorkbook or RefTableRangeInClosedWorkbook
'         RefCurrentRegionBottomRight
'     ReplaceColumnDataMatchingInDict
'         GetColumnRange
'         ReplaceDataColumnMatchingInDict
'     AutoFilterDeleteEntireRows
'         GetColumnOfIntegers
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteMatchingRows()
    Const ProcName As String = "DeleteMatchingRows"
    Dim IsSuccess As Boolean
    On Error GoTo ClearError
    
    ' Time Passed
    Dim tt As Double: tt = Timer ' Total Time
    Dim t As Double: t = tt ' Time Per Operation
    Dim tf As String: tf = "0.0000" ' Time Format
    Dim tc As Double
    
    ' Source
    Const sFilePath As String = "C:\Test\2021\70269924\FileA.xlsx"
    Const swsName As String = "Sheet1" ' "Sheet2"
    Const sfCellAddress As String = "H2"
    Const sDictItem As Variant = Empty
    Dim sDictCompareMode As VbCompareMethod: sDictCompareMode = vbTextCompare
    ' Note that if 'dIsThisWB = False' and 'sIsThisWb = True',
    ' the source workbook remains open regardlessly. 'sIsThisWb = True' is used
    ' for testing purposes or if both workbooks are 'ThisWorkbook'.
    ' In the latter case, don't forget to check that the worksheet names
    ' are different.
    Const sIsThisWB As Boolean = False ' if 'True', 'sDoCloseWB' has no effect
    Const sDoCloseWB As Boolean = True ' regardlessly changes will not be saved
    
    ' Destination
    Const dFilePath As String = "C:\Test\2021\70269924\FileB.xlsx"
    Const dwsName As String = "Sheet1"
    Const dtrgFirstCellAddress As String = "A1"
    Const dCriteriaCol As Long = 7 ' range column in this case 'G'
    Const dFirstReplacementRow As Long = 2
    ' Be careful with the following three constants, there is no undo.
    Const dIsThisWB As Boolean = False
    Const dDoSaveWB As Boolean = False
    Const dDoCloseWB As Boolean = False
    
    ' Other
    Const Replacement As String = "!"
    
    Debug.Print "Start '" & ProcName & "'...     "
    
    ' 1.
   Dim dict As Object
    If sIsThisWB Then
        Set dict = DictUniqueColumnFromThisWorkbook( _
            swsName, sfCellAddress, sDictItem, sDictCompareMode)
        tc = Timer
        Debug.Print "1. DictUniqueColumnFromThisWorkbook...    " _
            & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    Else
        Set dict = DictUniqueColumnFromClosedWorkbook(sFilePath, swsName, _
            sfCellAddress, sDictItem, sDictCompareMode, sDoCloseWB)
        tc = Timer
        Debug.Print "1. DictUniqueColumnFromClosedWorkbook...  " _
            & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    End If
    Debug.Print "    Found " & dict.Count & " unique values."
    
    ' 2.
    ' Creates a reference to the destination workbook. If the destination
    ' workbook is the workbook containing this code then you have to set
    ' the constant 'dIsThisWB' to 'True'. If the destination workbook
    ' is a closed workbook, you have to set the constant to 'False' and
    ' appropriately set the 'dFilePath' constant for the workbook to open.
    ' Creates a reference to the destination table range.
    Dim dtrg As Range
    If dIsThisWB Then
        Set dtrg = RefTableRangeInThisWorkbook(dwsName, dtrgFirstCellAddress)
        tc = Timer
        Debug.Print "2. RefTableRangeInThisWorkbook...     " _
            & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    Else
        Set dtrg = RefTableRangeInClosedWorkbook( _
            dFilePath, dwsName, dtrgFirstCellAddress)
        tc = Timer
        Debug.Print "2. RefTableRangeInClosedWorkbook...   " _
            & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    End If
    
    Debug.Print "    Created a reference to the table range '" _
         & dtrg.Address(0, 0) & "'" & vbLf & "    in the worksheet '" _
         & dwsName & "' of the workbook '" _
         & dtrg.Worksheet.Parent.Name & "'" & vbLf & "    in the folder '" _
         & dtrg.Worksheet.Parent.Path & "'."
    
    ' 3.
    Dim dcrrg As Range: Set dcrrg = dtrg.Columns(dCriteriaCol)
    ReplaceColumnDataMatchingInDict _
        dcrrg, dict, Replacement, dFirstReplacementRow
    Set dict = Nothing
    Dim dcrCount As Long: dcrCount = Application.CountIf(dcrrg, Replacement)
    
    tc = Timer
    Debug.Print "3. ReplaceColumnDataMatchingInDict...     " _
        & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    Debug.Print "    Replaced cell values with '" & Replacement & "' in " _
        & dcrCount & " rows."
    
    If dcrCount = 0 Then ' already deleted
        IsSuccess = True
        GoTo ProcExit
    End If
    
    ' 4.
    AutoFilterDeleteEntireRows dtrg, Replacement, dCriteriaCol
    
    tc = Timer
    Debug.Print "4. AutoFilterDeleteEntireRows...          " _
        & Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
    Debug.Print "    Deleted " & dcrCount & " matching rows."
    
    Dim dwb As Workbook: Set dwb = dtrg.Worksheet.Parent
    ' To close easily when testing, don't wanna delete for now
    dwb.Saved = True
    ' When done testing, out-comment the previous line and adjust
    ' the 'dIsThisWB', 'dDoCloseWB' and 'dDoSaveWB' constants.
    
    If Not dDoCloseWB Then ' save before 'IsSuccess' if not to be closed
        If dDoSaveWB Then dwb.Save
    End If

    IsSuccess = True
    
ProcExit:
    
    On Error GoTo ClearExitError
    
    If IsSuccess Then
        If Not dIsThisWB Then ' close before the message
            If dDoCloseWB Then
                dwb.Close SaveChanges:=dDoSaveWB
            End If
        End If
        MsgBox "Rows deleted: " & dcrCount, vbInformation, ProcName
        ' If you close 'ThisWorkbook' before the message, you won't see it.
        If dIsThisWB Then ' close after the message
            If dDoCloseWB Then
                dwb.Close SaveChanges:=dDoSaveWB
            End If
        End If
    Else
        MsgBox "Something went wrong." & vbLf _
            & "See the message in the VBE Immediate window (Ctrl+G).", _
            vbCritical, ProcName
    End If

    Debug.Print "End '" & ProcName & "'...     "

FinalExit:
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
ClearExitError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume FinalExit
End Sub

Module2

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values, from a column range in the worksheet
'               of a closed workbook, in the keys of a dictionary.
' Remarks:      The default dictionary item ('DictItem') is 'Empty'.
'               The default dictionary compare mode ('DictCompareMode')
'               is 'vbTextCompare' i.e. 'A = a'.
'               By default, closes the workbook not saving changes.
'               Removes any filters, being relevant if the workboook stays open.
' Remarks:      By default, closes the workbook not saving changes.
' Calls:        'RefColumn','GetColumnRange', and 'DictUniqueColumn'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumnFromClosedWorkbook( _
    ByVal FilePath As String, _
    ByVal WorksheetName As String, _
    Optional ByVal FirstCellAddress As String = "A1", _
    Optional ByVal DictItem As Variant = Empty, _
    Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare, _
    Optional ByVal DoCloseWorkbook As Boolean = True) _
As Object
    Const ProcName As String = "DictUniqueColumnFromClosedWorkbook"
    On Error GoTo ClearError

    Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
    Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Dim Data As Variant: Data = GetColumnRange(RefColumn(fCell))
    Set DictUniqueColumnFromClosedWorkbook _
        = DictUniqueColumn(Data, 1, DictItem, DictCompareMode)
    If DoCloseWorkbook Then wb.Close SaveChanges:=False

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values, from a column range in a worksheet
'               of the workbook containing this code, 'Thisworkbook',
'               in the keys of a dictionary.
' Remarks:      The default dictionary item ('DictItem') is 'Empty'.
'               The default dictionary compare mode ('DictCompareMode')
'               is 'vbTextCompare' i.e. 'A = a'.
'               Removes any filters.
' Calls:        'RefColumn','GetColumnRange', and 'DictUniqueColumn'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumnFromThisWorkbook( _
    ByVal WorksheetName As String, _
    Optional ByVal FirstCellAddress As String = "A1", _
    Optional ByVal DictItem As Variant = Empty, _
    Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare) _
As Object
    Const ProcName As String = "DictUniqueColumnFromThisWorkbook"
    On Error GoTo ClearError

    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(WorksheetName)
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Dim Data As Variant: Data = GetColumnRange(RefColumn(fCell))
    Set DictUniqueColumnFromThisWorkbook _
        = DictUniqueColumn(Data, 1, DictItem, DictCompareMode)
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Opens a workbook and for one of its worksheets,
'               creates a reference to a table range (headers).
' Remarks:      The workbook stays open and it can be referenced e.g. with
'               ' Dim wb As Workbook: Set wb = rg.Worksheet.Parent'.
'               Removes any filters.
' Calls:        'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefTableRangeInClosedWorkbook( _
    ByVal FilePath As String, _
    ByVal WorksheetName As String, _
    Optional ByVal FirstCellAddress As String = "A1") _
As Range
    Const ProcName As String = "RefTableRangeInClosedWorkbook"
    On Error GoTo ClearError
    
    Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
    Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Set RefTableRangeInClosedWorkbook = RefCurrentRegionBottomRight(fCell)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In the workbook containing this code ('Thisworkbook'),
'               for one of its worksheets, creates a reference
'               to a table range (headers).
' Remarks:      Removes any filters.
' Calls:        'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefTableRangeInThisWorkbook( _
    ByVal WorksheetName As String, _
    Optional ByVal FirstCellAddress As String = "A1") _
As Range
    Const ProcName As String = "RefTableRangeInThisWorkbook"
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(WorksheetName)
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Set RefTableRangeInThisWorkbook = RefCurrentRegionBottomRight(fCell)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Replaces the values in a column of a range, found
'               in the keys of a dictionary, with a string.
' Remarks:      Formulas in the column will be converted to values.
' Calls:        'GetColumnRange','ReplaceDataColumnMatchingInDict'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ReplaceColumnDataMatchingInDict( _
        ByRef rg As Range, _
        ByVal dict As Object, _
        ByVal Replacement As String, _
        Optional ByVal FirstReplacementRow As Long = 1, _
        Optional ByVal ColumnNumber As Long = 1)
    Const ProcName As String = "ReplaceColumnDataMatchingInDict"
    On Error GoTo ClearError
    
    Dim crg As Range: Set crg = rg.Columns(ColumnNumber)
    Dim cData As Variant: cData = GetColumnRange(crg)
    ReplaceDataColumnMatchingInDict _
        cData, dict, Replacement, FirstReplacementRow
    crg.Value = cData

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Filters a range on a string and deletes the entire rows
'               of the filtered (visible) cells.
' Remarks:      Removes any filters.
' Calls:        'GetColumnOfIntegers'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AutoFilterDeleteEntireRows( _
        ByVal TableRange As Range, _
        ByVal FilterString As String, _
        Optional ByVal FilterField As Long = 1)
    Const ProcName As String = "AutoFilterDeleteEntireRows"
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = TableRange.Worksheet
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim trrCount As Long: trrCount = TableRange.Rows.Count
    Dim ntrcCount As Long: ntrcCount = TableRange.Columns.Count + 1 ' new
    
    ' Increase the table range by a column and create a reference to it.
    Dim NewTableRange As Range
    Set NewTableRange = TableRange.Resize(, ntrcCount)
    
    ' Write incrementing numbers to the new column.
    With NewTableRange
        With .Columns(ntrcCount) ' new last column
            .Cells(1).Value = "C!!!" ' header
            .Resize(trrCount - 1).Offset(1).Value _
                = GetColumnOfIntegers(1, trrCount - 1) ' sequence of numbers
        End With
        
        ' Sort the criteria column ascending to get all criteria strings
        ' one after the other to increase the effieciency of deleting rows
        ' since there will be only one range area i.e. a contiguous range.
        .Sort .Columns(FilterField), xlAscending, , , , , , xlYes
        
        ' Create a reference to the data range, the new table range
        ' without headers. Do it before the auto-filtering.
        Dim DataRange As Range: Set DataRange = .Resize(trrCount - 1).Offset(1)
        
        .AutoFilter FilterField, FilterString ' with headers
        
        ' Create a reference to the filtered 'entire-row-range'
        ' ('DataVisibleRows') and delete it.
        Dim DataVisibleRows As Range
        On Error Resume Next
            Set DataVisibleRows = DataRange _
                .SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo ClearError
        If Not DataVisibleRows Is Nothing Then DataVisibleRows.Delete
        
        ws.AutoFilterMode = False
        
        ' Sort the new table range by its last column and clear it.
        .Sort .Columns(ntrcCount), xlAscending, , , , , , xlYes
        .Columns(ntrcCount).Clear
    End With
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub

Module3

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
' Remarks:      It is not safe to use it with merged cells and in filtered
'               worksheets. Hidden rows or columns are allowed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a column ('ColumnNumber')
'               of a range ('rg') to a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnNumber As Long = 1) _
As Variant
    Const ProcName As String = "GetColumnRange"
    On Error GoTo ClearError
    
    With rg.Columns(ColumnNumber)
        If rg.Rows.Count = 1 Then
            Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
            GetColumnRange = Data
        Else
            GetColumnRange = .Value
        End If
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values, from a column ('ColumnIndex')
'               of a 2D one-based array ('Data'), in the keys of a dictionary.
'               The default dictionary item ('DictItem') is 'Empty'
'               The default dictionary compare method ('DictCompareMethod')
'               is 'vbTextCompare' i.e. 'A=a'.
' Remarks:      Error and empty values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumn( _
    ByVal Data As Variant, _
    Optional ByVal ColumnIndex As Long = 1, _
    Optional ByVal DictItem As Variant = Empty, _
    Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare) _
As Object
    Const ProcName As String = "DictUniqueColumn"
    On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = DictCompareMode
    Dim Key As Variant
    Dim r As Long
    For r = 1 To UBound(Data, 1)
        Key = Data(r, ColumnIndex)
        If Not IsError(Key) Then ' exclude error values
            If Not IsEmpty(Key) Then ' exclude empty values
                dict(Key) = DictItem
            End If
        End If
    Next r
    Set DictUniqueColumn = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range from a cell ('FirstCell')
'               to the last cell of its current region.
' Remarks:      Useful when there is data (e.g. a title) adjacent
'               to the top or to the left of a table range
'               (obviously not allowed in an Excel table range).
'               If the first cell is cell 'A1' or there is no adjacent data,
'               it references the current region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegionBottomRight"
    On Error GoTo ClearError
    
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegionBottomRight = _
            FirstCell.Resize(.Row + .Rows.Count - FirstCell.Row, _
            .Column + .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Compares the values in a column of a 2D one-based array ('Data')
'               with the values in the keys of a dictionary ('dict')
'               and replaces any matching values in the array,
'               with a string ('Replacement').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ReplaceDataColumnMatchingInDict( _
        ByRef Data As Variant, _
        ByVal dict As Object, _
        ByVal Replacement As String, _
        Optional ByVal FirstReplacementRow As Long = 1, _
        Optional ByVal DataColumn As Long = 1)
    Const ProcName As String = "ReplaceDataColumnMatchingInDict"
    On Error GoTo ClearError
    
    Dim Key As Variant
    Dim dr As Long
    For dr = FirstReplacementRow To UBound(Data, 1)
        Key = Data(dr, DataColumn)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                If dict.Exists(Key) Then
                    Data(dr, DataColumn) = Replacement
                End If
            End If
        End If
    Next dr

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a sequence of integers
'               in a 2D one-base one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnOfIntegers( _
    ByVal StartInteger As Long, _
    ByVal EndInteger As Long, _
    Optional ByVal StepInteger As Long = 1) _
As Variant
    Const ProcName As String = "GetColumnOfIntegers"
    On Error GoTo ClearError
    
    Dim IsStepPositive As Boolean: IsStepPositive = (StartInteger <= EndInteger)
    
    Dim siCount As Long
    Dim drCount As Long
    
    If IsStepPositive Then
        siCount = EndInteger - StartInteger + 1
    Else
        siCount = StartInteger - EndInteger + 1
    End If
    
    Dim siStep As Long: siStep = Abs(StepInteger)
    
    drCount = Int(siCount / siStep)
    If siCount Mod siStep > 0 Then
        drCount = drCount + 1
    End If
    
    If Not IsStepPositive Then
        siStep = -siStep
    End If
        
    Dim dData() As Long: ReDim dData(1 To drCount, 1 To 1)
    Dim si As Long
    Dim dr As Long
    
    For si = StartInteger To EndInteger Step siStep
        dr = dr + 1
        dData(dr, 1) = si
    Next si
    
    GetColumnOfIntegers = dData
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function