更快的查找方法和过滤器位置比较？

Question

问题：我必须在一张大表中搜索特定的保单编号。当有近 75,000 行时，查找功能需要相当长的时间。关于如何比较这两张 75,000 行的表格有什么建议吗？我认为可能可行的解决方案是对每张纸进行排序，然后获取需要找到的保单编号并将其与中间行进行比较。有没有办法比较该策略编号并查看在简单排序函数中它是否大于或小于？在找到那个比较之后，我会重置上限和下限并再次找到中间。 ......这会更快吗？还有其他建议吗？

谢谢

当前代码：

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

Scott 已经提供了答案，但仅供参考，这里是一些示例代码，说明了使用 Find() 和使用 Dictionary 查找包含相同 10k 值的未排序范围内的 10k 个单独值之间的区别。

在我的电脑上输出：

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

代码（需要参考“Microsoft Scripting Runtime”库）：

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

Answer 2

您的代码很慢有几个原因，但主要是因为您如何单独循环遍历每个单元格（实际的Find 函数并不是减慢它的原因）。

下面，我已将您的搜索列放入一个数组并循环遍历它，这将快得多。我还删除了您所有的 select 和 activate 语句，因为它们在 VBA 中 99% 的时间都是无关紧要的，并且还会稍微减慢您的代码速度。最后，我关闭了ScreenUpdating，这也有帮助。

如果我在重构中遗漏了什么，请告诉我。

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