Optimize this VBA lookup loop in Excel

Question

I want to optimize the following code, as it is very slow. I am using the code found in this answer: https://stackoverflow.com/a/27108055/1042624

However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.

Sub DeleteCopy2()

Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long

Application.ScreenUpdating = False
Application.Calculation = xlManual

strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1

LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row

ReDim arrVal(2 To LastRow) ' Headers in row 1

For CurRow = LBound(arrVal) To UBound(arrVal)
    If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        Sheets("MatchData").Range("A" & CurRow).Value = ""
    Else
    End If
Next CurRow

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows

Logic

1. Store search values in array 1
2. Store destination values in array 2
3. Loop through the first array and check if it is present in the second array. If present, clear it
4. Clear the search values from sheet1
5. Output the array to the sheet1
6. Sort Col A so that the blanks go down.

Code

Sub Sample()
    Dim wbMatch As Worksheet, wbDestSheet As Worksheet
    Dim lRow As Long, i As Long
    Dim MArr As Variant, DArr As Variant
    Dim strSheetName As String
    Dim rng As Range

    strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1

    '~~> Set your worksheets
    Set wbMatch = Sheets("MatchData")
    Set wbDestSheet = Sheets(strSheetName)

    '~~> Store search values in 1st array
    With wbMatch
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set rng = .Range("A2:A" & lRow)
        MArr = rng.Value
    End With

    '~~> Store destination values in the 2nd array
    With wbDestSheet
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        DArr = .Range("A2:A" & lRow).Value
    End With

    '~~> Check if the values are in the other array
    For i = LBound(MArr) To UBound(MArr)
        If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
    Next i

    With wbMatch
        '~~> Clear the range for new output
        rng.ClearContents

        '~~> Output the array to the worksheet
        .Range("A2").Resize(UBound(MArr), 1).Value = MArr

        '~~> Sort it so that the blanks go down
        .Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    End With
End Sub

'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
    Dim j As Long

    For j = 1 To UBound(arr, 1)
        On Error Resume Next
        IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
        On Error GoTo 0
        If IsInArray = True Then Exit For
    Next
End Function

Edit

Another way. Based on the sample file, this code runs in approx 1 minute.

Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM

Logic:

It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter

Sub Sample()
    Dim wbMatch As Worksheet, wbDestSheet As Worksheet
    Dim lRow As Long
    Dim strSheetName As String
    Dim rng As Range

    Debug.Print "Start : " & Now

    strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1

    '~~> Set your worksheets
    Set wbMatch = Sheets("MatchData")
    Set wbDestSheet = Sheets(strSheetName)

    '~~> Store search values in 1st array
    With wbMatch
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        .Columns(2).Insert
        Set rng = .Range("B2:B" & lRow)

        lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row

        rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
        DoEvents

        rng.Value = rng.Value
        .Range("B1").Value = "Temp"

        'Remove any filters
        .AutoFilterMode = False

        With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
            .AutoFilter Field:=2, Criteria1:=">0"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        'Remove any filters
        .AutoFilterMode = False

        .Columns(2).Delete
    End With

    Debug.Print "End : " & Now
End Sub

Answer 2

Looks like @SiddarthRout and I were working in parallel...

My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.

Option Explicit

Sub DeleteCopy2()
    Dim codeTimer As CTimer
    Set codeTimer = New CTimer
    codeTimer.StartCounter

    Dim thisWB As Workbook
    Dim destSH As Worksheet
    Dim matchSH As Worksheet
    Set thisWB = ThisWorkbook
    Set destSH = thisWB.Sheets("Week 32")
    Set matchSH = thisWB.Sheets("MatchData")

    Dim lastMatchRow As Long
    Dim lastDestRow As Long
    lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
    lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row

    '--- copy working data into memory arrays
    Dim destArea As Range
    Dim matchData As Variant
    Dim destData As Variant
    matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
    Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
    destData = destArea

    Dim i As Long
    For i = 2 To lastDestRow
        If Not InMatchingData(matchData, destData(i, 1)) Then
            destData(i, 1) = ""
        End If
    Next i

    '--- write the marked up data back to the worksheet
    destArea = destData

    Debug.Print "Destination rows = " & lastDestRow
    Debug.Print "Matching rows    = " & lastMatchRow
    Debug.Print "Execution time   = " & codeTimer.TimeElapsed & " secs"
End Sub

Private Function InMatchingData(ByRef dataArr As Variant, _
                                ByRef dataVal As Variant) As Boolean
    Dim i As Long
    InMatchingData = False
    For i = LBound(dataArr) To UBound(dataArr)
        If dataVal = dataArr(i, 1) Then
            InMatchingData = True
            Exit For
        End If
    Next i
End Function

The timing results from my code are (using the timer class from this post ):

Destination rows = 35773
Matching rows    = 23848
Execution time   = 36128.4913359179 secs