Optimizing VBA code running time finding username of a range in another worksheet and return value if found

Question

Good day all , I am trying to find each cell value in column A of worksheet "OFSHC" in worksheet "User Assessments" and if value found then return "true" in column V of the corresponding cell in worksheet "OFSHC" else return "false. I have the code below , however; I am working with +90000 rows in worksheet "OFSHC" and +900000 rows in sheet "User Assessments" , which makes the code to run over 6 hours. any idea on optimizing the code to run for a shorter period of time?

Code:

Sub findUsername_OFSHC_User_Assessments()

Worksheets("OFSHC").Activate

    Dim FindString As String
    Dim Rng As Range

    For Each Cell In Range("A2:A35000")
        FindString = Cell.Value
        
        If Trim(FindString) <> "" Then
            'The 2nd worksheet is assumed to be User Assessments. Change this if it is not the case
            With Sheets("User Assessments").Range("D1:D900000")
                Set Rng = .Find(What:=FindString, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.GoTo Rng, True
                    'In Sheet 2: This line shifts 5 cells to the right and gets the country value
                    'Found = ActiveCell.Offset(0, 5).Value
                    'In Sheet 1: Found value is pasted into the cell 3 cells to the right of the cell containing the Workday usernme
                    Cell.Offset(0, 22).Value = "True"
                Else
                    Cell.Offset(0, 22).Value = "False"
                End If
            End With
        End If

    Next
End Sub

Answer 1

Lookup Data Using Application.Match

• Adjust the values in the constants section.
• First, test it on a smaller dataset since it'll still take some time (not tested on a large dataset).
• Only run the first procedure which will call the remaining two when necessary.

Option Explicit

Sub findUsername_OFSHC_User_Assessments()
    
    ' Constants
    Const sName As String = "User Assessments"
    Const sFirst As String = "D2"
    Const dName As String = "OFSHC"
    Const lFirst As String = "A2"
    Const dFirst As String = "V2"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sData As Variant: sData = getColumn(wb.Worksheets(sName).Range(sFirst))
    If IsEmpty(sData) Then Exit Sub
    
    ' Lookup
    Dim ldData As Variant: ldData = getColumn(wb.Worksheets(dName).Range(lFirst))
    If IsEmpty(ldData) Then Exit Sub
    Dim rCount As Long: rCount = UBound(ldData, 1)
    
    ' Destination
    Dim r As Long
    For r = 1 To rCount
        If IsNumeric(Application.Match(ldData(r, 1), sData, 0)) Then
            ldData(r, 1) = True ' "'True"
        Else
            ldData(r, 1) = False ' "'False"
        End If
    Next r
    
    ' Write
    writeDataSimple wb.Worksheets(dName).Range(dFirst), ldData, True

End Sub

Function getColumn( _
    FirstCellRange As Range) _
As Variant
    Const ProcName As String = "getColumn"
    On Error GoTo clearError
    
    If Not FirstCellRange Is Nothing Then
        With FirstCellRange.Cells(1)
            Dim lCell As Range
            Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , , xlPrevious)
            If Not lCell Is Nothing Then
                Dim rCount As Long: rCount = lCell.Row - .Row + 1
                Dim Data As Variant
                If rCount = 1 Then
                    ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
                Else
                    Data = .Resize(rCount).Value
                End If
                getColumn = Data
            End If
        End With
    End If

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

Sub writeDataSimple( _
        ByVal FirstCellRange As Range, _
        ByVal Data As Variant, _
        Optional ByVal doClearContents As Boolean = True)
    Const ProcName As String = "writeDataSimple"
    On Error GoTo clearError
    
    If Not FirstCellRange Is Nothing Then
        If Not IsEmpty(Data) Then
            Dim rCount As Long: rCount = UBound(Data, 1)
            With FirstCellRange.Cells(1).Resize(, UBound(Data, 2))
                .Resize(rCount).Value = Data
                If doClearContents Then
                    .Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
                        .Offset(rCount).ClearContents
                End If
            End With
        End If
    End If

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

Answer 2

Here's a dictionary-based example using the same range sizes (35k lookup values against a 900k list).

In my testing it ran in < 10sec.

Notes:

1. Loading up a dictionary gets progressively slower as the number of items get larger, so here we're keeping the size below 100k by using a bunch of dictionaries, which collectively all load faster (~8-9sec) than loading all the values into a single dictionary (>50sec). We lose a bit of speed on the lookups, but still much faster.
2. This is based on all of your ColA values being unique - if they're not then whether or not that matters would depend on your exact use case. In this specific instance you're just looking for any match, so it's OK, but if for example you wanted to find all matches from a non-unique list you'd need to re-work the approach.

Sub Tester()

    Dim dict, arr, t, r As Long, arr2, arrRes, i As Long
    Dim colDicts As New Collection, arrK, res As Boolean
    
    t = Timer
    
    Set dict = CreateObject("scripting.dictionary")
    
    arr = Range("A2:A900000").Value 'the lookup range
    
    For r = 1 To UBound(arr, 1)
        If r Mod 100000 = 1 Then
            Set dict = CreateObject("scripting.dictionary")
            colDicts.Add dict
        End If
        dict(arr(r, 1)) = True
    Next r

    Debug.Print "Loaded dictionaries", Timer - t 
    
    arr2 = Range("C2:C35000").Value             'values to be found
    ReDim arrRes(1 To UBound(arr2, 1), 1 To 1)  'size array for results
    For r = 1 To UBound(arr2, 1)
        res = False
        For Each dict In colDicts               'check each dictionary
            If dict.exists(arr2(r, 1)) Then
                res = True
                Exit For                        'done checking
            End If
        Next dict
        arrRes(r, 1) = res                      'assign true/false
    Next r
    
    Range("D2").Resize(UBound(arr2, 1), 1).Value = arrRes
    
    Debug.Print "Done", Timer - t '< 10sec

End Sub