How can I speed up the macro I created to delete rows based on text in one of the columns

[DBams]

Hi all,

I am new on the forum, so lets start with an introduction. I am Dennis, living in the Netherlands (sorry for my ((d)english ) and working as a data analist. One of the tools I use is excel and I using VBA/Macro's to make my life a bit easier.

At the moment I have created a Macro to delete some rows on tab named "check" when the text in column "I" is not in column "E" at the tab named "B". The Macro is working but it is very slow, due too the large amount of data. Tab "check" haves 100k rows and after the macro 50% will be deleted after running the macro. Tab "B" have 50 rows, so the discision to keep the data is based on 50 factors. I already paused screen updates and calculation to speedup the performance.

See the code bellow, can anybody advise how I can make it faster?

Thanks for your help!

Sub SettingCheck()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsBeFeed As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cell As Range
    
     Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

   Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Check")
    Set wsB = wb.Worksheets("B")
    lastRow1 = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRow2 = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    Set rng1 = ws.Range("I2:I" & lastRow1)
    Set rng2 = wsB.Range("E2:E" & lastRow2)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each cell In rng1
        If WorksheetFunction.CountIf(rng2, cell.Value) = 0 Then
            cell.EntireRow.Delete
        End If
    Next cell

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Moderator's note: Please take the time to review our rules. There aren't many, and they are all important. Rule #2 requires code tags. I have added them for you this time because you are a new member. --6StringJazzer

[KOKOSEK]

If it is only issue that value exists on other list, maybe this way will be a bit faster:

For Each cell In rng1
    If IsError(Application.Match(cell.Value, rng2, 0)) Then
        cell.EntireRow.Delete
    End If
Next cell

[Sintek]

Welcome to the forum DBams...Loops are generally very slow especially if you are looping data in the sheet and deleting rows...
It will be advisable to store data into arrays and then loop...
Something like this...Assumes data starts in A1 on sheet Check...

Sub J3v16()
Dim Data, Crit, i As Long
With Sheets("B"): Crit = .Range("E2:E" & .Cells(.Rows.Count, 5).End(xlUp).Row): End With
With Sheets("Check").Cells(1).CurrentRegion
    Data = .Value
    For i = 2 To UBound(Data)
        If IsError(Application.Match(Data(i, 9), Crit, 0)) Then Data(i, 9) = ""
    Next i
    .Value = Data
    '! Here first sorting and then clearing could be faster...
    .Columns(9).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

If not, please upload a sample file representing your actual file which one could work with...

[Marc L]

Here first sorting and then clearing could be faster

After I demonstrated that several times I'm happy someone else at least remind and apply it !

[johnnyL]

After I demonstrated that several times I'm happy someone else at least remind and apply it !

I think that method of coding has been been proven to be slower in this case.

[windknife]

Maybe, merge all rows into range, then only delete once .

Sub SettingCheck()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsBeFeed As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cell As Range
    
    Dim rng3 As Range
    Dim count As Integer
    count = 0
    
    
     Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

   Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Check")
    Set wsB = wb.Worksheets("B")
    lastRow1 = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
    lastRow2 = wsB.Cells(wsB.Rows.count, "A").End(xlUp).Row
    Set rng1 = ws.Range("I2:I" & lastRow1)
    Set rng2 = wsB.Range("E2:E" & lastRow2)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each cell In rng1
        If WorksheetFunction.CountIf(rng2, cell.Value) = 0 Then
            If count = 0 Then
                Set rng3 = cell.EntireRow
                count = count + 1
            Else
                Set rng3 = Union(rng3, cell.EntireRow)
            End If
        End If
    Next cell
    If count > 0 Then
        rng3.EntireRow.Delete
    End If

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

[johnnyL]

Without any data to test with, the following is what I came up with, in my head:

Sub SettingCheck_V2()
'
' If value in Column I of 'Check' is not found in Column E of 'B' then delete the row from 'Check'
'
    Dim StartTime                   As Double
    StartTime = Timer
'
    Dim MatchFound                  As Boolean
    Dim B_ArrayRow                  As Long, Check_ArrayRow             As Long
    Dim LastColumnNumberInCheck     As Long
    Dim NumberOfRowsToDelete        As Long
    Dim B_ColumnE_Array             As Variant, Check_ColumnI_Array     As Variant
    Dim HelperColumnArray()         As Variant
'
    Application.ScreenUpdating = False                                                                          ' Turn ScreenUpdating off to improve performance
       Application.Calculation = xlCalculationManual                                                            ' Turn calculation mode off to improve performance
'
    With Sheets("Check")
        Check_ColumnI_Array = .Range("I2:I" & .Range("A" & .Rows.Count).End(xlUp).Row).Value2                   '   Save column I values from Sheets("Check") into 2D 1 Based Check_ColumnI_Array
'
        LastColumnNumberInCheck = .Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column              '   Get the # of the last used column in Sheets("Check")
    End With
'
    With Sheets("B")
        B_ColumnE_Array = .Range("E2:E" & .Range("A" & .Rows.Count).End(xlUp).Row).Value2                       '   Save column E values from Sheets("B") into 2D 1 Based B_ColumnE_Array
    End With
'
    ReDim HelperColumnArray(1 To UBound(Check_ColumnI_Array), 1 To 1)                                           ' Size the HelperColumnArray to the same # of rows as Check_ColumnI_Array
'
    For Check_ArrayRow = 1 To UBound(Check_ColumnI_Array)                                                       ' Loop thru rows of Check_ColumnI_Array
        For B_ArrayRow = 1 To UBound(B_ColumnE_Array)                                                           '   Loop thru rows of B_ColumnE_Array
            If Check_ColumnI_Array(Check_ArrayRow, 1) = B_ColumnE_Array(B_ArrayRow, 1) Then                     '       If a matching value is found then ...
                MatchFound = True                                                                               '           Set MatchFound flag = True
                Exit For                                                                                        '           Exit this For loop
            End If
        Next                                                                                                    '   Loop back
'
        If Not MatchFound Then                                                                                  '   If a Match was not found then ...
            NumberOfRowsToDelete = NumberOfRowsToDelete + 1                                                     '       Increment NumberOfRowsToDelete
            HelperColumnArray(Check_ArrayRow, 1) = 1                                                            '       Set row in HelperColumnArray = 1
        End If
'
        MatchFound = False                                                                                      '   Set MatchFound Flag = False
    Next                                                                                                        ' Loop back
'
    If NumberOfRowsToDelete > 0 Then                                                                            ' If there are rows to be deleted then ...
        With Sheets("Check").Range("A2").Resize(UBound(Check_ColumnI_Array), LastColumnNumberInCheck + 2)       '   Set range for possible deletion of rows
            .Columns(LastColumnNumberInCheck + 2).Value = HelperColumnArray                                     '       Write the HelperColumnArray to the Last used column of Sheets("Check") + 2
            .Sort Key1:=.Columns(LastColumnNumberInCheck + 2), Order1:=xlAscending, Header:=xlNo                '       Sort the Rows with '1's to the top
            .Resize(NumberOfRowsToDelete).EntireRow.Delete                                                      '       Delete the rows with '1's all at once
        End With
    End If
'
    Debug.Print "Time to complete script = " & Timer - StartTime & " seconds."                                  ' Display completion time of the script to the 'Immediate' window ... CTRL+G in the VBE
    MsgBox "Time to complete script = " & Timer - StartTime & " seconds."                                       ' Display completion time of the script to the user
'
    Application.Calculation = xlCalculationAutomatic                                                            ' Turn calculation mode back on
    Application.ScreenUpdating = True                                                                           ' Turn ScreenUpdating back on
End Sub

This is normally a very fast approach.

[jindon]

Set rng1 = ws.Range("I2:I" & lastRow1)

Assuming I1 has header.

Sub test()
    Dim rng As Range, r As Range
    With ThisWorkbook.Sheets("b")
        Set rng = .Range("e2", .Range("e" & Rows.Count).End(xlUp))
    End With
    With ThisWorkbook.Sheets("check")
        Set r = .Cells(1, .Cells.SpecialCells(11).Column + 2).Resize(2)
        r(2).Formula = "=iserror(match(i2," & rng.Address(, , , 1) & ",0))"
        With .Range("i1", .Range("i" & Rows.Count).End(xlUp))
            .AdvancedFilter 1, r
            If .SpecialCells(12).Count > 1 Then
                .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
            End If
        End With
        If .FilterMode Then .ShowAllData
        r.Clear
    End With
End Sub

[DBams]

Thank you all for your answers, looks really helpfull. Can't wait to try, unfortunatly I have a very busy day today so I will try these solutions next week and let you know.

[Sintek]

Upload a sample file in the meanwhile so we can see actual file setup...

[veyselemre]

Alternative;

Sub test()
    Dim lCol%, lRow&, lRow2&, a As String

    With Sheets("B")
        lRow = .Cells(Rows.Count, "E").End(3).Row
        If lRow = 1 Then Exit Sub
        a = "B!" & .Range("E2:E" & lRow).Address()
    End With

    With Sheets("Check")
        .Range("J:J").ClearContents
        lCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
        lRow = .Cells(Rows.Count, "I").End(xlUp).Row
        With .Range(Cells(2, lCol), Cells(lRow, lCol))
            .Formula = "=IF(COUNTIF(" & a & ",I2)>0,ROW(),"""")"
            .Value = .Value
        End With

        .UsedRange.Sort .Cells(2, lCol), , , , , , , xlYes
        lRow2 = .Cells(Rows.Count, lCol).End(xlUp).Row
        If lRow2 < lRow Then .Range(lRow2 + 1 & ":" & lRow).Delete
        .Columns(lCol).Delete
    End With

End Sub

[Sintek]

Or another option...

Sub J3v16()
Dim lr As Long
With Sheets("B"): lr = .Cells(.Rows.Count, 5).End(xlUp).Row: End With
With Sheets("Check").Cells(1).CurrentRegion
    With .Columns(9).Offset(1).Resize(.Rows.Count - 1)
        .Value = Evaluate("=IF(ROW(" & .Address & "),IF(ISNUMBER(MATCH(" & .Address & ",'B'!E2:E" & lr & ",0))," & .Address & ",""""))")
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End With
End Sub

[leelnich]

Hi all -I generated 100000 rows of sample data (strings) and used a timing program to compare everybody's solutions. It's all in the attached workbook.

.SpeedsComp.jpg

As you can see, 3 programs blew away the other 5. All 3 loaded a column with formulas or values to mark rows for deletion, and then sorted on that column to move them to the bottom of the region. With all the "remove" rows together, no "keeper" rows had to be shifted, so deletion was almost instantaneous.

Here's my code. Credit to @veyselemre, whose Range construction I copied:

Sub SettingCheck_LLN_like_veyselemre()

    'Bounding and range definitions by veyselemre@ExcelForums.com
    'Formula and clearance by LLN@ExcelForums.com 2023-6-16
    'https://www.excelforum.com/excel-programming-vba-macros/1407300-how-can-i-speed-up-the-macro-i-created-to-delete-rows-based-on-text-in-one-of-the-columns.html#post5839040
    'https://www.excelforum.com/excel-programming-vba-macros/1223081-remove-duplicate-rows-based-on-criteria.html#post4859357

    Application.ScreenUpdating = False
    
    Dim lCol%, lRow&, a As String

    With Sheets("B")
        lRow = .Cells(Rows.count, "E").End(xlUp).Row
        If lRow = 1 Then Exit Sub
        a = "B!" & .Range("E2:E" & lRow).Address
    End With

    With Sheets("Check")
        lCol = .Cells(1, Columns.count).End(xlToLeft).Column + 1
        lRow = .Cells(Rows.count, "I").End(xlUp).Row
        With .Range(.Cells(2, lCol), .Cells(lRow, lCol))
            .Formula = "=0/MATCH(I2," & a & ",0)"
'            .Formula = "=0/(INDEX(" & a & ",MATCH(I2," & a & ",1))=I2)"  '...for sorted settings. ~8% faster @ 50 values
            .Value = .Value                                               'However, a BIG boost if you had 1000+

        On Error Resume Next
            .Parent.UsedRange.Sort .Cells(1), Header:=xlYes
            .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete  'Clear is faster, if you don't need to shift cells up or alter row heights.
            .ClearContents
        On Error GoTo 0
        End With
    End With
    
    Application.ScreenUpdating = True
    
End Sub

The formula I put in column J (and then resolved to Values):

=0/MATCH(I2,B!$E$2:$E$51,0)

This yielded zeros for Keeper rows and Errors for Remove rows. I used these to sort the data, found the Errors w/ SpecialCells, and deleted those rows.

[Sintek]

...Deleted...Not Important...

[johnnyL]

I would have to agree with the results from @leelnich, but I would like to add a footnote ... the script I provided is built for stamina, in other words, the ROR (Rate of Return) remains fairly constant with increasing amount of rows.

On my testing computer, the code I submitted, with the testing data submitted, processed about 100k rows / second. The other codes submitted that used formulas, rapidly fall off on the timings as the amount of rows being tested increases. Ie. Try 500k results ;

The op in this thread clearly stated 100k rows being tested & the submission winner, thus far in this thread, goes to @leelnich. !!!

Another side note, @leelnich, I normally test the timing of scripts multiple times & then remove the highest recorded time as well as the lowest recorded time & then get an average of the remaining values.

[Sintek]

Kudos to you guys...Best I can do incorporating my suggestion in post 3 with my code in Post 10...

'! Here first sorting and then clearing could be faster...

Is 1.97, 1.96, 1.98 with 100K

Sub J3v16()
Dim Tm As Double, lr As Long: Tm = Timer
With Sheets("B"): lr = .Cells(.Rows.count, 5).End(xlUp).Row: End With
With Sheets("Check").Cells(1).CurrentRegion
    With .Columns(9).Offset(1).Resize(.Rows.count - 1)
        .Value = Evaluate("=IF(ROW(" & .Address & "),IF(ISNUMBER(MATCH(" & .Address & ",'B'!E2:E" & lr & ",0))," & .Address & ",""""))")
        '! Here first sorting and then clearing could be faster...
        .Sort .Cells(1), xlAscending, , , , , , xlNo
        .SpecialCells(xlCellTypeBlanks).EntireRow.Clear '! Delete
    End With
End With
Debug.Print Format(Timer - Tm, "0.00")
End Sub

[leelnich]

... And we have a NEW Champ (@ 100,000 rows)!!
NOTE: I noticed sintek used Clear instead of Delete. I changed that and re-tested his code. Not much difference; he's still fastest.
NOTE#2 Just realized sintek's code only sorts column I; it needs to sort the whole data region, using column I as the key field. ANOTHER re-test...

Plus, here's my new code. It handles all data sizes fairly well:

Sub SettingCheck_LLN_02()
    'Bounding and range definitions by veyselemre@ExcelForums.com
    'Formula and clearance by LLN@ExcelForums.com 2023-6-16
    'https://www.excelforum.com/excel-programming-vba-macros/1407300-how-can-i-speed-up-the-macro-i-created-to-delete-rows-based-on-text-in-one-of-the-columns.html#post5839040
    'https://www.excelforum.com/excel-programming-vba-macros/1223081-remove-duplicate-rows-based-on-criteria.html#post4859357
    
    Application.ScreenUpdating = False
    
    Dim lCol%, lRow&, a As String, c As Long

    With Sheets("B")
        lRow = .Cells(Rows.count, "E").End(xlUp).Row
        If lRow = 1 Then Exit Sub
        a = "B!" & .Range("E2:E" & lRow).Address
    End With

    With Sheets("Check")
        lCol = .Cells(1, Columns.count).End(xlToLeft).Column + 1
        lRow = .Cells(Rows.count, "I").End(xlUp).Row
        With .Range(.Cells(2, lCol), .Cells(lRow, lCol))
            .Formula = "=SIGN(MATCH(I2," & a & ",0))"
'            .Formula = "=0/(LOOKUP(I2," & a & "," & a & ")=I2)"                  '...for sorted settings. ~2% faster @ 50 values
            .Value = .Value                                                       'However, a BIG boost if you had 1000+

        On Error Resume Next
            .EntireRow.Sort .Cells(1), Header:=xlNo
            c = WorksheetFunction.count(.Columns(1))
            .EntireRow.Resize(.Rows.count - c, lCol).Offset(c).Delete (xlShiftUp)   'Clear is faster, but doesn't clean up row heights or shift cells.
            .ClearContents
        On Error GoTo 0
        End With
    End With
    
    Application.ScreenUpdating = True
    '"=SIGN(MATCH(I2,B!$E$2:$E$51,0))"
    '"=0/(LOOKUP(I2,B!$E$2:$E$51,B!$E$2:$E$51)=I2)"
End Sub

[MikeVol]

Hello @DBams
Another option according to your first post.

Sub SubSettingCheck_Array()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsB As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim rng1 As Range
    Dim rng2 As Range
    Dim deleteRows() As Boolean
    Dim i As Long
    
    'Disable screen updating and calculations
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Check")
    Set wsB = wb.Worksheets("B")
    lastRow1 = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRow2 = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    Set rng1 = ws.Range("I2:I" & lastRow1)
    Set rng2 = wsB.Range("E2:E" & lastRow2)
    
    'Initialize array to keep track of rows to delete
    ReDim deleteRows(1 To rng1.Rows.Count)
    
    'Loop through values in first range and mark rows to delete if value not found in second range
    For i = 1 To rng1.Rows.Count

        If WorksheetFunction.CountIf(rng2, rng1.Cells(i, 1).Value) = 0 Then
            deleteRows(i) = True
        End If

    Next i
    
    'Delete marked rows
    For i = rng1.Rows.Count To 1 Step -1

        If deleteRows(i) Then
            ws.Rows(i + 1).EntireRow.Delete
        End If

    Next i
    
    'Enable screen updating and calculations
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

[leelnich]

So, after re-doing my "Check" test sheet to include data in columns A:I (it was just column I), and altering all routines to sort that WHOLE region (sintek):

.CompTimes4.jpg

Here's my test workbook. I had to chop off Archive Data to get it small enough to comply w/ forum rules,
so I added a Workbook_Open procedure to expand the portion I could save. - Lee
ps. Output is still partly manual, but I don't have time to clean that up right now. Feel free to tinker . . . and post your improvements. Thanks.

[johnnyL]

I have taken off the gloves & rolled up my sleeves :

Sub SettingCheck_V3_johnnyL()
'
' If value in Column I of 'Check' is not found in Column E of 'B' then delete the row from 'Check'
'
    Dim B_ArrayRow                  As Long, Check_ArrayRow             As Long
    Dim LastColumnNumberInCheck     As Long
    Dim Dictionary_B                As Object
    Dim B_ColumnE_Array             As Variant, Check_ColumnI_Array     As Variant
    Dim HelperColumnArray()         As Variant
'
    Application.Calculation = xlCalculationManual                                                               ' Turn calculation mode off to improve performance
'
    With Sheets("Check")
        Check_ColumnI_Array = .Range("I2:I" & .Range("I" & .Rows.count).End(xlUp).Row).Value2                   '   Save column I values from Sheets("Check") into 2D 1 Based Check_ColumnI_Array
'
        LastColumnNumberInCheck = .Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column              '   Get the # of the last used column in Sheets("Check")
    End With
'
    With Sheets("B")
        B_ColumnE_Array = .Range("E2:E" & .Range("E" & .Rows.count).End(xlUp).Row).Value2                       '   Save column E values from Sheets("B") into 2D 1 Based B_ColumnE_Array
    End With
'
    ReDim HelperColumnArray(1 To UBound(Check_ColumnI_Array), 1 To 1)                                           ' Size the HelperColumnArray to the same # of rows as Check_ColumnI_Array
'
    Set Dictionary_B = CreateObject("Scripting.dictionary")                                                     ' Establish Dictionary_B
'
    For B_ArrayRow = 1 To UBound(B_ColumnE_Array, 1)                                                            ' Loop through rows of B_ColumnE_Array
        Dictionary_B(B_ColumnE_Array(B_ArrayRow, 1)) = B_ArrayRow                                               '   Save value from B_ColumnE_Array to Dictionary_B
    Next                                                                                                        ' Loop back
'
    For Check_ArrayRow = 1 To UBound(Check_ColumnI_Array, 1)                                                    ' Loop through rows of Check_ColumnI_Array
        If Not Dictionary_B.exists(Check_ColumnI_Array(Check_ArrayRow, 1)) Then                                 '   If Lookup value is not found in Dictionary_B then ...
            HelperColumnArray(Check_ArrayRow, 1) = 1                                                            '       Save a '1' to the HelperColumnArray row
        End If
    Next                                                                                                        ' Loop back
'
        With Sheets("Check").Range("A2").Resize(UBound(Check_ColumnI_Array), LastColumnNumberInCheck + 2)       '   Set range for deletion of rows
            .Columns(LastColumnNumberInCheck + 2).Value2 = HelperColumnArray                                    '       Write the HelperColumnArray to the Last used column of Sheets("Check") + 2
            .Sort Key1:=.Columns(LastColumnNumberInCheck + 2), Order1:=xlAscending, Header:=xlNo                '       Sort the Rows with '1's to the top
            .Resize(Sheets("Check").Cells(Rows.count, LastColumnNumberInCheck + 2).End(xlUp).Row - 1).EntireRow.Delete  '       Delete the rows with '1's all at once
        End With
'
    Application.Calculation = xlCalculationAutomatic                                                            ' Turn calculation mode back on
End Sub

Side note: I move to have @sintek disqualified because altering the arrangement of the rows was not specifically authorized in the OP.

[leelnich]

...Side note: I move to have @sintek disqualified because altering the arrangement of the rows was not specifically authorized in the OP.

Just realized what you meant! Sintek's original code left column I out of sync with the rest of the data, but his final version does in fact change the sort order.

@sintek, maybe we can sell it as a "feature", rather than a bug...

[johnnyL]

Results from my most recent testings:

[leelnich]

VERY NICE, @johnnyL, you nailed it!

.CompTimes4.jpg

I thought somebody would eventually go with a dictionary object; @Jindon, in particular, has used them often in his posts to good effect, but he seems to have gone dormant on this thread.

ps: I just saw your timings post. You clearly have a faster computer than I; my 2016 Lenovo ideapad 110 is a total potato.

[johnnyL]

As long as the computer and the excel version and the coding are kept constant for all the testing, The actual timing results don't really matter. When I say that, what i am referring to is the fastest code in one particular setup should be the fastest code in another particular setup. Ie. If the fastest code on your setup completes in 5 seconds, that same code should test the fastest on another computer, it may be slower or faster than your particular timing, but the faster code should be faster, all other things kept equal while testing.

I know I probably didn't explain that properly, but I hope the point is received.

[leelnich]

Yes, I'm aware that the testing platform is irrelevant* here. I was just envying a faster machine.

*Note that specific hardware may favor certain processes, and vice-versa. For example, code optimized to run on many-threaded machines will not do well on my 4-thread laptop. Of course, while Excel can be configured to use multiple threads, VBA is always single-threaded. This is one reason I would not be too eager to dismiss the performance of worksheet functions ON THE WORKSHEET.

[johnnyL]

VBA is always single-threaded?

Well that is a debate for another day.

[leelnich]

...Well that is a debate for another day.

Not just another day, but another thread! We're getting WAY off topic.

@DBams, we hope we've given you a workable solution, and perhaps some food for thought. Welcome to Excel Forums.

If you are satisfied with the proposed solution(s), please go to Thread Tools above your first post and mark the thread as SOLVED.
Also, since you're new to the site, clicking the Add Reputation stars beneath useful posts is a great way to show appreciation
to those who offered help.

[johnnyL]

You are correct in essence, but possibly don't know about workarounds to 'simulate' multithreading. Google Asynchronous and Daniel Ferry.

[Sintek]

sort that WHOLE region (sintek):

OOps...your sample file confused me lol...Replacement of End With and columns(9).sort solves
Glad you guys enjoyed OP's thread...
Happy Coding...

[leelnich]

OOps...your sample file confused me lol...

Yeah, yeah . . . it was kinda cobbled together, and then I had to pare it down to 1 MB to comply w/ upload limitations.

From your first post: ... '! Here first sorting and then clearing could be faster...

Good instinct, it's amazing how quickly Excel sorts. I wish it extended to VBA arrays, too, although coding a sort function is interesting.

[kevin9999]

I note this thread still hasn't been marked as "solved" yet, so I thought I might use it as my first post on this site since becoming a member. I used leelnich 's sample file in post #11 as the basis. First post so I hope I don't stuff it up.

Option Explicit
Sub kevin9999()
    Dim t As Double: t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Check")
    Set ws2 = Worksheets("B")
    
    Dim LRow As Long, LCol As Long, i As Long
    LRow = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    
    Dim a, b, c, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    a = ws2.Range("E2", ws2.Cells(Rows.count, "E").End(xlUp))
    b = ws1.Range("I2", ws1.Cells(Rows.count, "I").End(xlUp))
    ReDim c(1 To UBound(b, 1), 1 To 1)
    
    For i = 1 To UBound(a, 1)
        d(a(i, 1)) = 1
    Next i
    
    For i = 1 To UBound(b, 1)
        If Not d.exists(b(i, 1)) Then c(i, 1) = 1
    Next i
    
    ws1.Cells(2, LCol).Resize(UBound(c)) = c
    i = WorksheetFunction.Sum(ws1.Columns(LCol))
    
    If i > 0 Then
        ws1.Range(ws1.Cells(2, 1), ws1.Cells(LRow, LCol)).Sort Key1:=ws1.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws1.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
    
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox Timer - t & " secs."
End Sub

[johnnyL]

Sorry, I am just getting off a night of watching some of my favorite rap videos so I thought I would drop a few bars here:

Let's all welcome kevin from MrExcel
It's his first post here so don't bid him a fare well
He's responding to the post from the OP DBams
So please don't reply with any frikkin slams

I can vouch for the dude, he is great at Excel
Overtime I am sure you will see this as well
With that being said, let's look at the code
And Give the respect that kevin is owed

[johnnyL]

I believe we have a new champion!

Attachment 833896

[leelnich]

kevin9999 gets my vote! Simple, robust, and fast!

.CompALL.jpg

Posted by Marc L

Posted by sintek
Here first sorting and then clearing could be faster

After I demonstrated that several times I'm happy someone else at least remind and apply it !

Posted by johnnyL
I think that method of coding has been been proven to be slower in this case.

@johnnyL - to what method are you referring? As the above chart clearly demonstrates, sorting before deletion yields a huge advantage in processing time. That is far and away the single most important conclusion OP should draw from this thread. The rest is minor differences in implementation.
@Marc L - Your implication of ownership notwithstanding, people have been 'sorting before deletion' since VBA was introduced in the 90's!

[Marc L]

@Marc L - Your implication of ownership notwithstanding:rolleyes

You misread or misunderstood …
As for years within this forum I've never have seen some helper sharing a VBA procedure following 'the kid way' (1)
so one day I posted a code changing from the usual answers …
Few days later, another thread with a similar subject, the same helpers sharing their same slower ways …
So I shared again the same way … The same during months, maybe years …
So now you should be able to understand why I'm happy with Sintek's post !

What is the best code ? The faster ? Maybe if it's a speed challenge
but usually the best code could not be the faster but the one the OP can maintain himself …

(1) Why I called it 'the kid way' ?
'cause one day in a company the team had to attend to a presentation with its author,
you know the kind of guy when there is an issue he's never involved
but when something works that's thanks to him even if he never worked on the project,
so proud he was with its last project (so boring it was in fact)
and at the end he launched via a button a 'cleaning' VBA procedure removing rows
which was lasting for ages, more than ten minutes, so the director which was the final user
became red and started to shout how unhappy he was !
Then the miracle started : we heard a little young voice arguing
« I don't understand it can be so long as manually that should not take no more than two minutes, maybe one ! »
This voice was the one of a 'summer job' young guy. So the director asked for a demonstration
and the 'kid' did the same than the VBA procedure within a minute, all operating manually !
So from that day I decided to try to first see what Excel offers first before going to a full looping VBA code …

[AliGW]

@kevin9999

Welcome to ExcelForum!

[kevin9999]

Thank you AliGW, leelnich & JohnnyL

[Marc L]

With more than 400-500 K unique items the Dictionary becomes slower and slower
so for big / huge data it's not the way to go, it should be replaced with a Collection
or better just using array(s) when that's possible …

[leelnich]

With more than 400-500 K unique items the Dictionary becomes slower and slower...

That might apply if we were removing duplicates (as an example), but kevin9999 (and johnnyL) are just using it
to contain settings (an implicitly short-ish list), not the entire data column.

...So from that day I decided to try to first see what Excel offers first before going to a full looping VBA code …

Agreed. You're not going to beat Excel at its own game. Identify those operations it does best (including some array operations), and let it do them.

[Sintek]

@ lee...Already posted reply

OOps...your sample file confused me lol...Replacement of End With and columns(9).sort solves

[leelnich]

@sintek - Just kidding around ... no offense was intended.

Question: Your evaluated formula is wrapped in an extra IF clause that returns TRUE for every row. Is that to coerce an array return?

=IF(ROW($I$2:$I$100001),IF(ISNUMBER(MATCH($I$2:$I$100001,'B'!E2:E51,0)),$I$2:$I$100001,""))

I ask because occasionally during testing, your code deleted ALL data, implying no array was generated. I'm not sure why; it was very inconsistent. May I suggest using the INDEX function as a more reliable method for coercing arrays:

=INDEX(IF(ISNUMBER(MATCH($I$2:$I$100001,'B'!E2:E51,0)),$I$2:$I$100001,""),)

Postscript - Please ignore the above, your code seems to run fine on its own; the problem must lie with my test.
If I can't figure it out, I'll start a new thread. I don't want to suck any more air out of this one.

pps: - 6/27/2023 - I eventually realized sintek inadvertently used a local range reference in his Evaluated formula, causing an error if the wrong sheet was active at run time.
The solution was to specify the sheet in the range string (and drop the IF(ROW... ) wrapper; the formula works fine without it):

=IF(ISNUMBER(MATCH(Check!$I$2:$I$100001,B!$E$2:$E$51,0)),Check!$I$2:$I$100001,"")

[Sintek]

@ Lee
None taken...
Not sure how you are populating your formula...I'm guessing the inconsistency is due to the error in the formula...

=IF(ROW($I$2:$I$100001),IF(ISNUMBER(MATCH($I$2:$I$100001,B!E$2:E$51,0)),$I$2:$I$100001,""))

Amazing though...Post 41 and OP has still not responded...Also, we have no idea how his actual workbook is setup...

[leelnich]

@sintek - is the formula in post#42 the corrected version? I'm guessing yes, since a relative address there doesn't make sense.

BTW, the reason I focused on your code so hard was your interesting use of the EVALUATE method to produce a large array that gets written to the worksheet.
I thought perhaps you might be on to something, but testing proved it's quicker to just let Excel calculate a column and convert it to values.

[Sintek]

For that purpose you need a absolute reference E$2:E$51...copy your formula down and you will see the inconsistency in results...
Evaluate on smaller datasets is generally much faster that formula to value conversion and loop...when dealing with less than 2 seconds for code to run...it's user choice I guess...Anyway...interesting thread...so nice to have different available options given to users...
Happy Coding Guys...Till next time...

[leelnich]

...Evaluate on smaller datasets is generally much faster that formula to value conversion and loop...

Sorry, I know you're ready to move on, but it's not fair to directly contradict what I said in post#43 and not expect a response. I agree that EVALUATE is faster than looping in some cases, but if you're writing the array back to the sheet, it's NOT faster than formula-to-value conversion.

Here's two versions of your program (altered to fix sort). They both put a 1 in column J for matches, and "" for misses. The ONLY difference is, the first writes a formula to the sheet and converts it to values. The second EVALUATEs an array version of the same formula and writes the array to the sheet, as your original code did.

Sub sintek3_ALTERED_Formula2Sheet()
Application.ScreenUpdating = False
Dim a As String, b As String
b = "B!$E$2:" & Sheets("B").Cells(Rows.count, "E").End(xlUp).Address()
With Sheets("Check").Cells(1).CurrentRegion
    With .Columns(.Columns.count + 1).Offset(1).Resize(.Rows.count - 1)
        .Formula = "=IF(ISNUMBER(MATCH(I2," & b & ",0)),1,"""")"
        .Value = .Value
        .EntireRow.Resize(, .Column).Sort .Cells(1), xlAscending, , , , , , xlNo
        .SpecialCells(xlCellTypeBlanks).EntireRow.Resize(, .Column).Delete
        .Clear
    End With
End With
Application.ScreenUpdating = True
'=IF(ISNUMBER(MATCH(I2,'B'!$E$2:$E$51,0)),1,"")
End Sub


Sub sintek3_ALTERED_Array2Sheet()
Application.ScreenUpdating = False
Dim a As String, b As String
b = "B!$E$2:" & Sheets("B").Cells(Rows.count, "E").End(xlUp).Address()
With Sheets("Check").Cells(1).CurrentRegion
    With .Columns(.Columns.count + 1).Offset(1).Resize(.Rows.count - 1)
        a = .EntireRow.Columns("I").Address(external:=True)
        .Value = Evaluate("IF(ISNUMBER(MATCH(" & a & "," & b & ",0)),1,"""")")
        .EntireRow.Resize(, .Column).Sort .Cells(1), xlAscending, , , , , , xlNo
        .SpecialCells(xlCellTypeBlanks).EntireRow.Resize(, .Column).Delete
        .Clear
    End With
End With
Application.ScreenUpdating = True
'=IF(ISNUMBER(MATCH(Check!$I$2:$I$100001,B!$E$2:$E$51,0)),1,"")
End Sub

.CompareSub5.jpg

[leelnich]

3 weeks later . . . just realized I never uploaded the finished version of my Timing Workbook.

Cleaner code, WAY better output (fully automated), plus some notes on data creation.

[MikeVol]

3 weeks later . . . just realized I never uploaded the finished version of my Timing Workbook.

Okay. What about this code? The code written is not mine, I say right away.

Option Explicit

' Sub         : DelRows(TableHeader,ColNum,DelValue)
' TableHeader : Range; table header range
' ColNum      : Long; column number with DelValue
' DelValue    : Variant; value of rows to be deleted
'-------------+---------------------------------------------------------------------
' VBA call    : DelRows ThisWorkbook.Worksheets("Check").Range("A1:I1"), 9, "BigLongString------------------------------------NOT FOUND"
'-------------+---------------------------------------------------------------------
' Created     : ZVI:2009:12:26
'-----------------------------------------------------------------------------------
Sub DelRows(TableHeader As Range, ColNum As Long, DelValue)
    Dim Arr(), r&, rs&, rsAft&, cs&, i&, v, ac

    Dim t1 As Double, t2 As Double
    Dim totalTime   As Double
    t1 = Timer

    ' Freeze on
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        ac = .Calculation: .Calculation = xlCalculationManual
    End With

    Restore_Data

    With TableHeader.CurrentRegion
        rs = .Rows.Count - TableHeader.Row + .Row
        cs = .Columns.Count - TableHeader.Column + .Column
    End With

    With TableHeader.Resize(rs, 1)
        Arr() = .Offset(, cs).Value

        ' Check DelValue
        For Each v In .Offset(, ColNum - 1).Value
            r = r + 1

            If v <> DelValue Then
                i = i + 1
                Arr(r, 1) = 1
            End If

        Next

        If i < rs Then

            ' Delete rows with DelValue in ColNum
            .Offset(, cs) = Arr
            .Resize(, cs + 1).Sort .Cells(1).Offset(, cs), 1, Header:=xlNo
            .Resize(, 1).Offset(, cs).ClearContents

            .Resize(rs - i).Offset(i).EntireRow.Delete
        End If

    End With

    With TableHeader.CurrentRegion
        rsAft = .Rows.Count - TableHeader.Row + .Row
    End With

    ' Freeze off
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = ac
    End With

    ' Time difference in seconds
    t2 = Timer
    totalTime = (t2 - t1)
    MsgBox "Total rows before: " & rs & vbCr & vbCr & "Lead time: " & Format(totalTime, "#0.00") & " seconds" & vbCr & vbCr & "Total rows after: " & rsAft, vbInformation
End Sub

' Testing
Sub TestDelRows()
    DelRows ThisWorkbook.Worksheets("Check").Range("A1:I1"), 9, "BigLongString------------------------------------NOT FOUND"
End Sub

[leelnich]

@MikeVol - Your code in post#47 doesn't even mention Sheet("B"); it merely deletes all rows containing instances of BigLongString------------------------------------NOT FOUND, a stand-in value intended to represent any entries not found on the list.
How does that meet @DBams original requirement to verify membership for all entries?

Just to be thorough, I did test BOTH your code submissions (post#16, post#47):

.TimesMikeV.jpg

Your code reads individual cells in a loop, which is VERY SLOW. In general, may I suggest reading entire ranges into an array - a single operation - and looping thru that, as @JohnnyL did in post#5.