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

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:
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.
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