更快的查找方法和filter位置比较？

问题：我不得不search一个大的工作表，了解具体的政策编号。 当有近75,000行时，查找函数需要相当长的一段时间。 有关如何比较这两个75000行的任何build议？ 我认为解决scheme可能会工作将sorting每个工作表，然后采取需要find的政策号码，并将其与中间行进行比较。 有没有办法比较该保单号码，看看在简单的sortingfunction，它会更大或更小？ find比较后，我会重置上下界，再次find中间。 …这会更快吗？ 还有其他build议吗？

谢谢

当前代码：

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

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

下面，我把你的search列放入一个数组中，并循环，这将会快得多。 我也拿出了所有的select和activate语句，因为它们在VBA中占了99％的时间，并且也会使代码变慢。 最后，我closures了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 

Answer 2

Scott已经提供了一个答案，但是这里的FYI是一些示例代码，说明了使用Find（）和使用Dictionary来查找包含相同10k值的未sorting范围内的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