Excel 查找速度与 VBA 二进制搜索？

Question

Excel VBA 的查找与二分搜索的好/快？我的平台是 Office 11|2003，我将在三张值上针对 A 列搜索字符串。总行数 ~140,000

如果值得我应该参考哪些库和函数来进行排序然后进行二分搜索？据报道，二进制搜索字符串/文本存在潜在问题。

...一件事 必须注意。使用二分查找 带有 sortedtext 的公式需要 警告。 Aladin A., Excel MVP

Excel 查找：

Worksheets(1).Range("A:A").Find("PN-String-K9", LookIn:=xlValues, LookAt:=xlWhole)

Answer 1

与我的直觉非常相反，VBA 二进制搜索的性能明显优于 Excel 查找。至少在下面的场景中，120,000 个 6 字符串均匀分布在 3 个工作表上。

Excel 查找需要 1 分 58 秒，
在我的特定机器上，VBA 二进制搜索需要 36 秒。

知道文本有序的优势显然超过了 Excel 的自然优势。注意 Aladin A 关于排序顺序的警告。

Option Explicit

' Call Search to look for a thousand random strings
' in 3 worksheets of a workbook

' requires a workbook with 3 sheets and
' column A populated with values between "00001" to "120000"
' split evenly 40,000 to a worksheet in ascending order.
' They must be text, not numbers.

Private Const NUM_ROWS As Long = 120000
Private Const SHEET_1 As String = "Sheet1"
Private Const SHEET_2 As String = "Sheet2"
Private Const SHEET_3 As String = "Sheet3"

' This uses VBA Binary Search
Public Sub Search()
    Worksheets(SHEET_1).Range("B:B").ClearContents
    Worksheets(SHEET_2).Range("B:B").ClearContents
    Worksheets(SHEET_3).Range("B:B").ClearContents
    DoSearch True       ' change to False to test Excel search
End Sub

' Searches for a thousand values using binary  or excel search depending on
' value of bBinarySearch
Public Sub DoSearch(ByVal bBinarySearch As Boolean)
    Debug.Print Now
    Dim ii As Long

    For ii = 1 To 1000
        Dim rr As Long
        rr = Int((NUM_ROWS) * Rnd + 1)
        If bBinarySearch Then
            Dim strSheetName As String
            Dim nRow As Long
            If BinarySearch(MakeSearchArg(rr), strSheetName, nRow) Then
                Worksheets(strSheetName).Activate
                Cells(nRow, 1).Activate
            End If
        Else
            If Not ExcelSearch(SHEET_1, MakeSearchArg(rr)) Then
                If Not ExcelSearch(SHEET_2, MakeSearchArg(rr)) Then
                    ExcelSearch SHEET_3, MakeSearchArg(rr)
                End If
            End If
        End If
        ActiveCell.Offset(0, 1).Value = "FOUND"
    Next
    Debug.Print Now

End Sub

' look for one cell value using Excel Find
Private Function ExcelSearch(ByVal strWorksheet As String _
  , ByVal strSearchArg As String) As Boolean
    On Error GoTo Err_Exit
    Worksheets(strWorksheet).Activate
    Worksheets(strWorksheet).Range("A:A").Find(What:=strSearchArg, LookIn:=xlValues, LookAt:= 
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True 
        , SearchFormat:=False).Activate
    ExcelSearch = True
    Exit Function
Err_Exit:
    ExcelSearch = False
End Function

' Look for value using a vba based binary search
' returns true if the search argument is found in the workbook
' strSheetName contains the name of the worksheet on exit and nRow gives the row
Private Function BinarySearch(ByVal strSearchArg As String _
  , ByRef strSheetName As String, ByRef nRow As Long) As Boolean
    Dim nFirst As Long, nLast As Long
    nFirst = 1
    nLast = NUM_ROWS
    Do While True
        Dim nMiddle As Long
        Dim strValue As String
        If nFirst > nLast Then
            Exit Do     ' Failed to find search arg
        End If
        nMiddle = Round((nLast - nFirst) / 2 + nFirst)
        SheetNameAndRowFromIdx nMiddle, strSheetName, nRow
        strValue = Worksheets(strSheetName).Cells(nRow, 1)
        If strSearchArg < strValue Then
            nLast = nMiddle - 1
        ElseIf strSearchArg > strValue Then
            nFirst = nMiddle + 1
        Else
            BinarySearch = True
            Exit Do
        End If
    Loop
End Function

' convert 1 -> "000001", 120000 -> "120000", etc
Private Function MakeSearchArg(ByVal nArg As Long) As String
    MakeSearchArg = Right(CStr(nArg + 1000000), 6)
End Function

' converts some number to a worksheet name and a row number
' This is depenent on the worksheets being named sheet1, sheet2, sheet3

' and containing an equal number of vlaues in each sheet where
' the total number of values is NUM_ROWS
Private Sub SheetNameAndRowFromIdx(ByVal nIdx As Long _
  , ByRef strSheetName As String, ByRef nRow As Long)
    If nIdx <= NUM_ROWS / 3 Then

        strSheetName = SHEET_1
        nRow = nIdx
    ElseIf nIdx > (NUM_ROWS / 3) * 2 Then
        strSheetName = SHEET_3
        nRow = nIdx - (NUM_ROWS / 3) * 2
    Else
        strSheetName = SHEET_2
        nRow = nIdx - (NUM_ROWS / 3)
    End If
End Sub

Answer 2

我发现使用自动筛选比使用任何方法手动搜索记录要快得多。

我过滤，检查是否有任何结果，然后继续。如果找到（通过检查结果计数），我可以搜索手动过滤的小部分或全部返回。

我在大约 44,000 条记录上使用了它，并针对它搜索了 100 多个部分的列表。

如果您不小心，二进制搜索很容易陷入无限循环。

Answer 3

如果您使用带有 sorted 选项的 vlookup，它可能会比您的 vba 更快。

Answer 4

我对此产生了兴趣，因为我正在使用 .Find 功能，并且在一台 PC 上它无法进行某些查找，但在另一台 PC 上没问题！所以我对时间进行了一些测试——我有一张按顺序排序的 985 个名称的表格，我编写了一个小子程序来运行它们，并使用不同的方法在同一个列表中查找每个名称（时间以毫秒为单位）：

1. 蛮力：2000
2. .查找：750
3. Application.VLookup: 265
4. 二分查找：234

VLookup 的问题是它不能返回行号，除非你把它包含在你的表中。

这是我的二进制搜索代码，我假设工作表有一个标题行，但您可以轻松修改标题和代码以传递该信息。可选的 Col 参数用于指示您是否需要行号或单元格的值。如果查找失败，该函数返回 0（零）。

Function Find(Sheet As Worksheet, What As String, Optional Col As Long = 0) As Variant
Dim Top As Long
Dim Mid As Long
Dim Bot As Long 'Bottom
Dim S As String
Dim T As String

   With Sheet
     Top = 2 'Sheet has a header row
     Bot = .UsedRange.Rows.Count
     S = LCase(What)
     Do
       Mid = (Top + Bot) / 2
       T = LCase(.Cells(Mid, 1))
       Select Case True
       Case T > S
         Bot = Mid - 1
       Case T < S
         Top = Mid + 1
       Case Else 'T = S
         If Col = 0 Then
           Find = Mid  'Return the row
         Else
           Find = .Cells(Mid, Col).Value2 'Return the cell's value
         End If
         Exit Function
       End Select
     Loop Until Bot < Top
   End With
   Find = 0
End Function