Faster Find Method and filter position comparison?

Question

Issue: I'm having to search a large sheet for specific policy numbers. The find function takes quite a while when there are nearly 75,000 rows. Any suggestions on how to compare these two sheets of 75,000 rows? A solution i thought might work would be to sort each sheet and then take the policy number needed to be found and compare it to the middle row. Is there a way to compare that policy number and see if in the simple sort function it would be greater or less than? After finding that comparison, i would reset the upper and lower bounds and find the middle again. ...Would this be quicker? Are there any other suggestions?

Thank you

Current Code:

Sub policyComment()

Dim x As Integer
Dim endRow As Variant
Dim polSer As String
Dim foundVal As String
Dim commentVar As Variant        

Windows("SuspenseNoteMacro.xlsm").Activate
Sheets("Main").Select

Range("A2").Select
endRow = ActiveCell.End(xlDown)

x = 2

Do
    polSer = Range("A" + CStr(x)).Value

    Windows("010713 Suspense ALL.xlsm").Activate
    Sheets("Sheet1").Select

    Set foundRange = Sheets("Sheet1").Cells.Find(what:=polSer, LookIn:=xlFormulas, lookat:=xlWhole)

   'foundRange = ActiveCell.Value     
    If foundRange Is Nothing Then
        Windows("SuspenseNoteMacro.xlsm").Activate
        Sheets("Main").Select
        Range("J" + CStr(x)).Value = "Not Found"
    ElseIf foundRange <> "" Then
        Sheets("Sheet1").Cells.Find(what:=polSer, LookIn:=xlFormulas, lookat:=xlWhole).Activate
        commentVar = Range("J" + CStr(ActiveCell.Row)).Value
        Windows("SuspenseNoteMacro.xlsm").Activate
        Sheets("Main").Select
        Range("J" + CStr(x)).Value = commentVar
    End If

    x = x + 1
    Range("A" + CStr(x)).Select
    foundRange = ""
Loop Until (x = endRow)

End Sub

Answer 1

Your code is slow for a few reasons, but mainly because of how you are looping through each cell individually (the actual Find function is not what is slowing it down).

Below, I've put your search column into an array and looped through that, which will be much, much faster. I've also taken out all your select and activate statements, as they are extraneous 99% of the time in VBA, and can also slow down your code a bit. Lastly, I turned off ScreenUpdating which helps as well.

If I missed something in the refactoring, let me know.

Option Explicit

Sub policyComment()

Dim x As Long, endRow As Long, polSer As String, foundRange As range, commentVar As String
Dim varArr() As Variant
Dim wksMain As Worksheet, wks1 As Worksheet

Set wksMain = Sheets("Main")
Set wks1 = Sheets("Sheet1")

Application.ScreenUpdating = False

With wksMain

    endRow = .range("A" & .Rows.Count).End(xlUp).Row
    varArr = .range("A2:A" & endRow)

    For x = LBound(varArr) To UBound(varArr)

        polSer = varArr(x, 1)

        With wks1

            Set foundRange = .Cells.Find(polSer, LookIn:=xlFormulas, lookat:=xlWhole)

            If foundRange Is Nothing Then

                wksMain.range("J" & x + 1).Value = "Not Found" 'need to add 1 to x because arrays are zero based

            Else

                commentVar = .range("J" & foundRange.Row)
                wksMain.range("J" & x + 1).Value = commentVar ''need to add 1 to x because arrays are zero based

            End If

        End With

    Next

End With

Application.ScreenUpdating = True

End Sub

Answer 2

Scott already provided an answer, but FYI here is some sample code illustrating the difference between using Find() and using a Dictionary to look up 10k individual values in an unsorted range containing the same 10k values.

Output on my PC:

50.48828 sec using Find()
0.078125 sec to load dictionary (10000 keys)
0.015625 sec using Dictionary

Code (requires a reference to "Microsoft Scripting Runtime" library):

Sub TestFind()

    Dim arrToFind
    Dim numRows As Long, r As Long
    Dim f As Range, rngSrc As Range
    Dim t
    Dim d As Scripting.Dictionary

    Set rngSrc = Worksheets("Source").Range("A2:A10001")

    arrToFind = Worksheets("Dest").Range("A2:A10001").Value
    numRows = UBound(arrToFind, 1)

    t = Timer
    Debug.Print "Starting test using Find()"
    For r = 1 To numRows
        If r Mod 1000 = 0 Then Debug.Print "Row " & r
        Set f = rngSrc.Find(arrToFind(r, 1), , xlValues, xlWhole)
        If Not f Is Nothing Then
        'do something based on f
        End If
    Next r
    Debug.Print Timer - t & " sec using Find()"

    t = Timer
    Set d = UniquesFromRange(rngSrc)
    Debug.Print Timer - t & " sec to load dictionary (" & d.Count & " keys)"

    t = Timer
    Debug.Print "Starting test using Dictionary"
    For r = 1 To numRows
        If r Mod 1000 = 0 Then Debug.Print "Row " & r
        If d.Exists(arrToFind(r, 1)) Then
        'use value from dictionary
        End If
    Next r
    Debug.Print Timer - t & " sec using Dictionary"

End Sub

Function UniquesFromRange(rng As Range) As Scripting.Dictionary

    Dim d As New Scripting.Dictionary
    Dim c As Range, tmp

    For Each c In rng.Cells
       tmp = Trim(c.Value)
       If Len(tmp) > 0 Then
            If Not d.Exists(tmp) Then d.Add tmp, c.Offset(0, 1).Value
       End If
    Next c

    Set UniquesFromRange = d
 End Function