加快数组搜索，如果可能的话可能是 2D 集合？
Speeding up array search, Possibly 2D Collection if that is possible?
我需要一些帮助来加快当前代码的速度，我是 运行。
首先，我有一个大的 data sheet，大约有 180,000 行，还有一个 unique sheet，它只有那个大列表中的唯一值这大约是 9000 行，因此目前需要很长时间才能使此代码可行。当前 i 和 j 值只是用于测试代码是否正常工作的占位符。
我想创建一个集合来存储数据，这样一旦匹配，就可以将其从集合中删除，这样就不需要稍后再次检查 [=15] 中的另一个值=].
是否可以收集，因为我需要在添加第 4 个单元格的值之前检查 3 个条件？
我非常感谢任何帮助或建议，因为我真的只在 VBA 编程了几个星期。
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
Dim i As Integer, lastData As Long
Dim tempTerms As Integer
Dim OpenForms
Sheets("Data").Select
lastData = Range("A2").End(xlDown).Row
For i = 1 To Lastrow
uniqueArray(i, 2) = 0
Next i
i = 0
For i = 1 To 10 'Lastrow
tempTerms = 0
tempProj = uniqueArray(i, 1)
If i Mod 30 = 0 Then
openform = DoEvents
End If
For j = 2 To 10000 'lastData
If tempProj = Cells(j, 10).Value _
And Cells(j, 5).Value = 55 Then
tempTerms = tempTerms + Cells(j, 8).Value
End If
Next j
uniqueArray(i, 2) = tempTerms
Application.StatusBar = i
Next i
End Sub
这是我常用的超速：
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
Dim i As Integer, lastData As Long
Dim tempTerms As Integer
Dim OpenForms
call OnStart
code ...
Next i
call OnEnd
End Sub
ScreenUpdating = False 完成了大约 90% 的工作，剩下的只是为了确保它按预期运行。
编辑：
理论上，如果将 Dim tempTerms As Integer 更改为 Long 应该会更快。也许最好将 OpenForms 定义为某种东西。
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
过程隐式Public，参数隐式传递ByRef。作为维护者，我希望名为 getHours 的方法 得到 我的 "hours"，不管那是什么 - 但 Sub 过程不会 return 它的调用者的任何东西，就像 Function 一样。因此这个名字具有误导性。过程 做 一些事情，他们需要一个描述性的名称来说明它的作用，...然后代码需要按照名称所说的去做。
一致性也很重要：您有一个 camelCase public 过程名称，然后混合了 camelCase 和 PascalCase 参数名称。模块成员坚持 PascalCase，locals/parameters 使用 camelCase。或其他 - 只是一致。
LastRow 是 Integer 举起旗帜。 Integer 是一个 16 位有符号整数类型，使其最大值为 32,767，当您尝试将其分配给 32,768 或更高时会出现问题。请改用 Long - 一种更适合通用整数值的 32 位有符号整数类型 - 尤其是 对于 "row number" 之类的东西，它可以是在 Excel.
中远高于 100K
Dim i As Integer, lastData As Long
i 应该是 Long，并且 lastData 已分配，但从未被引用 - 删除它及其分配。说到这...
Sheets("Data").Select
lastData = Range("A2").End(xlDown).Row
不要 .Select 工作表。使用 Worksheet 对象代替：
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")
请注意 Range，未使用 Worksheet 对象限定，隐含地引用任何活动的工作表，在任何活动的工作簿中。除非您在工作表模块的代码隐藏中 - 在这种情况下它指的是该工作表。如果您打算这样做，请明确并改为 Me.Range 。如果不是，则使用 Worksheet 对象正确限定 Range 和 Cells 调用。
然后使用它：
lastData = dataSheet.Range("A2").End(xlDown).Row
更多整数：
Dim tempTerms As Integer
同样，没有理由使用 16 位整数类型，声明 As Long。
Dim OpenForms
这个程序到底需要知道打开表单的数量是为了什么？它没有。删除它。
openform = DoEvents
您正在分配给 openform，但您声明了 OpenForms。如果您的代码编译并且 运行s，这意味着您没有在模块的顶部指定 Option Explicit。做吧。这将阻止 VBA 愉快地编译拼写错误，并会强制您声明您使用的每个变量。这里 OpenForms 未被使用，openform 是未声明的 Variant 由 VBA 运行-time 即时声明。
老实说，我什至不知道 DoEvents return 编辑过任何东西 - 它 return 打开表单的数量让我觉得是一个巨大的 WTF。无论如何，这是我一直看到它的用法：
DoEvents
就是这样！是的，这会丢弃 returned 值。但是谁首先关心打开表单的数量？
tempProj 未声明。声明它。 j 未声明。声明一下。
读取单元格的值是危险的。单元格包含 Variant，因此无论何时将单元格的值读入 String 或 Long 或任何类型的变量，您都在使 VBA 执行隐式类型转换 - 转换这并不总是可能的。
这最终会崩溃 - 或者在这个或另一个项目中回来咬你：
If tempProj = Cells(j, 10).Value _
And Cells(j, 5).Value = 55 Then
tempTerms = tempTerms + Cells(j, 8).Value
End If
在执行此操作之前，您需要确保单元格不包含错误值。
If IsError(Cells(j, 10).Value) Or IsError(Cells(j, 5).Value) Or IsError(Cells(j, 8).Value) Then
MsgBox "Row " & j & " contains an error value in column 5, 8, or 10."
Exit Sub
End If
好的，那么性能呢？
- 当存在更好的类型时避免
Variant。
- 避免未声明的变量；他们总是
Variant。使用 Option Explicit.
- 避免隐式类型转换。
- 避免
Select 和 Activate。
- 避免
DoEvents.
- 避免更新 UI（状态栏等）。
- 避免在循环中访问工作表单元格。
将工作表的数据读入变体数组：
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")
Dim sheetData As Variant
sheetData = dataSheet.Range("A1:J" & lastData).Value
现在 sheetData 是一个二维数组，包含指定范围内的每个值 - 所有值都在瞬间复制到内存中。
所以 j 循环变成这样1:
Dim j As Long
For j = 2 To lastData
If tempProj = sheetData(j, 10) And sheetData(j, 5) = 55 Then
tempTerms = tempTerms + sheetData(j, 8)
End If
Next j
现在我明白你在做什么了。 uniqueArray 就是你的 return 值！仅通过查看方法的签名很难分辨 - 将其命名为 result 或更好的 outHoursPerTerm 将大大有助于使代码更容易一目了然地理解。
考虑将 Application.Cursor 设置为沙漏，完成后将其设置回默认值 - 也可能将状态栏设置为 "Please wait..." 或类似的东西。 如果事情花费的时间超过 5-8 秒，然后考虑为外循环的每几次迭代更新状态栏，但请注意做这将使过程相当慢。
切换计算、工作表事件、屏幕更新和诸如此类的东西，在这里没有帮助 - 你不是在任何地方写，只是阅读。使用内存中的二维数组，您应该会看到相当大的性能改进。
这个答案故意读起来像 Code Review 答案。有关改进工作代码（性能、可读性等）的问题通常更适合 CR。下次您需要帮助改进您的工作代码时考虑在 CR 上询问 - 因为您可以看到 CR 答案比典型的 SO 答案涵盖更多领域。
1未测试，写在答案框里。可能需要将行转置为列。
将 180K 行加载到数组中，必须对 180K 数组进行排序，然后对排序后的数组进行二进制搜索。
外循环每次迭代使用匹配行的memo，匹配完成后停止内循环条件测试。轻松进行界面更新。
每次外部迭代的 Doevents 都足够了。下面只是一些足够的函数：
Option Explicit
Sub getHours()
Dim arr1 As Variant, arr2 As Variant
arr1 = Sheet1.Range("A2:B9001").Value2
arr2 = Sheet2.Range("A2:J180001").Value2 'whatever your range is
QuickSort1 arr2, 10 'sorting data on column 10 as you had it.
Dim i As Long, j As Long, tempSum As Long
For i = 1 To UBound(arr1)
tempSum = 0
Dim retArr As Variant
retArr = wsArrayBinaryLookup(arr1(i, 1), arr2, 10, 10, False)
If Not IsError(retArr(0)) Then
If arr1(i, 1) = retArr(0) Then
Dim matchRow As Long
matchRow = retArr(1)
'Go through from matched row till stop matching
Do
If arr2(matchRow, 10) <> arr1(i, 1) Then Exit Do
If arr2(matchRow, 5) = 55 Then
tempSum = tempSum + arr2(matchRow, 8)
End If
matchRow = matchRow + 1
Loop While matchRow <= UBound(arr2)
End If
End If
arr1(i, 2) = tempSum
DoEvents
Next i
Sheet1.Range("A2:B9001").Value2 = arr1
End Sub
Public Sub QuickSort1( _
ByRef pvarArray As Variant, _
ByVal colToSortBy, _
Optional ByVal plngLeft As Long, _
Optional ByVal plngRight As Long)
Dim lngFirst As Long
Dim lngLast As Long
Dim varMid As Variant
Dim varSwap As Variant
If plngRight = 0 Then
plngLeft = LBound(pvarArray)
plngRight = UBound(pvarArray)
End If
lngFirst = plngLeft
lngLast = plngRight
varMid = pvarArray((plngLeft + plngRight) \ 2, colToSortBy)
Do
Do While pvarArray(lngFirst, colToSortBy) < varMid And lngFirst < plngRight
lngFirst = lngFirst + 1
Loop
Do While varMid < pvarArray(lngLast, colToSortBy) And lngLast > plngLeft
lngLast = lngLast - 1
Loop
Dim arrColumn As Long
If lngFirst <= lngLast Then
For arrColumn = 1 To UBound(pvarArray, 2)
varSwap = pvarArray(lngFirst, arrColumn)
pvarArray(lngFirst, arrColumn) = pvarArray(lngLast, arrColumn)
pvarArray(lngLast, arrColumn) = varSwap
Next arrColumn
lngFirst = lngFirst + 1
lngLast = lngLast - 1
End If
Loop Until lngFirst > lngLast
If plngLeft < lngLast Then QuickSort1 pvarArray, colToSortBy, plngLeft, lngLast
If lngFirst < plngRight Then QuickSort1 pvarArray, colToSortBy, lngFirst, plngRight
End Sub
Public Function wsArrayBinaryLookup( _
ByVal val As Variant, _
arr As Variant, _
ByVal searchCol As Long, _
ByVal returnCol As Long, _
Optional exactMatch As Boolean = True) As Variant
Dim a As Long, z As Long, curr As Long
Dim retArr(0 To 1) As Variant
retArr(0) = CVErr(xlErrNA)
retArr(1) = 0
wsArrayBinaryLookup = retArr
a = LBound(arr)
z = UBound(arr)
If compare(arr(a, searchCol), val) = 1 Then
Exit Function
End If
If compare(arr(a, searchCol), val) = 0 Then
retArr(0) = arr(a, returnCol)
retArr(1) = a
wsArrayBinaryLookup = retArr
Exit Function
End If
If compare(arr(z, searchCol), val) = -1 Then
Exit Function
End If
While z - a > 1
curr = Round((CLng(a) + CLng(z)) / 2, 0)
If compare(arr(curr, searchCol), val) = 0 Then
z = curr
retArr(0) = arr(curr, returnCol)
retArr(1) = curr
wsArrayBinaryLookup = retArr
End If
If compare(arr(curr, searchCol), val) = -1 Then
a = curr
Else
z = curr
End If
Wend
If compare(arr(z, searchCol), val) = 0 Then
retArr(0) = arr(z, returnCol)
retArr(1) = z
wsArrayBinaryLookup = retArr
Else
If Not exactMatch Then
retArr(0) = arr(a, returnCol)
retArr(1) = a
wsArrayBinaryLookup = retArr
End If
End If
End Function
Public Function compare(ByVal x As Variant, ByVal y As Variant) As Long
If IsNumeric(x) And IsNumeric(y) Then
Select Case x - y
Case Is = 0
compare = 0
Case Is > 0
compare = 1
Case Is < 0
compare = -1
End Select
Else
If TypeName(x) = "String" And TypeName(y) = "String" Then
compare = StrComp(x, y, vbTextCompare)
End If
End If
End Function
我需要一些帮助来加快当前代码的速度，我是 运行。
首先，我有一个大的 data sheet，大约有 180,000 行，还有一个 unique sheet，它只有那个大列表中的唯一值这大约是 9000 行，因此目前需要很长时间才能使此代码可行。当前 i 和 j 值只是用于测试代码是否正常工作的占位符。
我想创建一个集合来存储数据，这样一旦匹配，就可以将其从集合中删除，这样就不需要稍后再次检查 [=15] 中的另一个值=].
是否可以收集，因为我需要在添加第 4 个单元格的值之前检查 3 个条件？
我非常感谢任何帮助或建议，因为我真的只在 VBA 编程了几个星期。
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
Dim i As Integer, lastData As Long
Dim tempTerms As Integer
Dim OpenForms
Sheets("Data").Select
lastData = Range("A2").End(xlDown).Row
For i = 1 To Lastrow
uniqueArray(i, 2) = 0
Next i
i = 0
For i = 1 To 10 'Lastrow
tempTerms = 0
tempProj = uniqueArray(i, 1)
If i Mod 30 = 0 Then
openform = DoEvents
End If
For j = 2 To 10000 'lastData
If tempProj = Cells(j, 10).Value _
And Cells(j, 5).Value = 55 Then
tempTerms = tempTerms + Cells(j, 8).Value
End If
Next j
uniqueArray(i, 2) = tempTerms
Application.StatusBar = i
Next i
End Sub
这是我常用的超速：
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
Dim i As Integer, lastData As Long
Dim tempTerms As Integer
Dim OpenForms
call OnStart
code ...
Next i
call OnEnd
End Sub
ScreenUpdating = False 完成了大约 90% 的工作，剩下的只是为了确保它按预期运行。
编辑：
理论上，如果将 Dim tempTerms As Integer 更改为 Long 应该会更快。也许最好将 OpenForms 定义为某种东西。
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
过程隐式Public，参数隐式传递ByRef。作为维护者，我希望名为 getHours 的方法 得到 我的 "hours"，不管那是什么 - 但 Sub 过程不会 return 它的调用者的任何东西，就像 Function 一样。因此这个名字具有误导性。过程 做 一些事情，他们需要一个描述性的名称来说明它的作用，...然后代码需要按照名称所说的去做。
一致性也很重要：您有一个 camelCase public 过程名称，然后混合了 camelCase 和 PascalCase 参数名称。模块成员坚持 PascalCase，locals/parameters 使用 camelCase。或其他 - 只是一致。
LastRow 是 Integer 举起旗帜。 Integer 是一个 16 位有符号整数类型，使其最大值为 32,767，当您尝试将其分配给 32,768 或更高时会出现问题。请改用 Long - 一种更适合通用整数值的 32 位有符号整数类型 - 尤其是 对于 "row number" 之类的东西，它可以是在 Excel.
Dim i As Integer, lastData As Long
i 应该是 Long，并且 lastData 已分配，但从未被引用 - 删除它及其分配。说到这...
Sheets("Data").Select
lastData = Range("A2").End(xlDown).Row
不要 .Select 工作表。使用 Worksheet 对象代替：
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")
请注意 Range，未使用 Worksheet 对象限定，隐含地引用任何活动的工作表，在任何活动的工作簿中。除非您在工作表模块的代码隐藏中 - 在这种情况下它指的是该工作表。如果您打算这样做，请明确并改为 Me.Range 。如果不是，则使用 Worksheet 对象正确限定 Range 和 Cells 调用。
然后使用它：
lastData = dataSheet.Range("A2").End(xlDown).Row
更多整数：
Dim tempTerms As Integer
同样，没有理由使用 16 位整数类型，声明 As Long。
Dim OpenForms
这个程序到底需要知道打开表单的数量是为了什么？它没有。删除它。
openform = DoEvents
您正在分配给 openform，但您声明了 OpenForms。如果您的代码编译并且 运行s，这意味着您没有在模块的顶部指定 Option Explicit。做吧。这将阻止 VBA 愉快地编译拼写错误，并会强制您声明您使用的每个变量。这里 OpenForms 未被使用，openform 是未声明的 Variant 由 VBA 运行-time 即时声明。
老实说，我什至不知道 DoEvents return 编辑过任何东西 - 它 return 打开表单的数量让我觉得是一个巨大的 WTF。无论如何，这是我一直看到它的用法：
DoEvents
就是这样！是的，这会丢弃 returned 值。但是谁首先关心打开表单的数量？
tempProj 未声明。声明它。 j 未声明。声明一下。
读取单元格的值是危险的。单元格包含 Variant，因此无论何时将单元格的值读入 String 或 Long 或任何类型的变量，您都在使 VBA 执行隐式类型转换 - 转换这并不总是可能的。
这最终会崩溃 - 或者在这个或另一个项目中回来咬你：
If tempProj = Cells(j, 10).Value _ And Cells(j, 5).Value = 55 Then tempTerms = tempTerms + Cells(j, 8).Value End If
在执行此操作之前，您需要确保单元格不包含错误值。
If IsError(Cells(j, 10).Value) Or IsError(Cells(j, 5).Value) Or IsError(Cells(j, 8).Value) Then
MsgBox "Row " & j & " contains an error value in column 5, 8, or 10."
Exit Sub
End If
好的，那么性能呢？
- 当存在更好的类型时避免
Variant。 - 避免未声明的变量；他们总是
Variant。使用Option Explicit. - 避免隐式类型转换。
- 避免
Select和Activate。 - 避免
DoEvents. - 避免更新 UI（状态栏等）。
- 避免在循环中访问工作表单元格。
将工作表的数据读入变体数组：
Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")
Dim sheetData As Variant
sheetData = dataSheet.Range("A1:J" & lastData).Value
现在 sheetData 是一个二维数组，包含指定范围内的每个值 - 所有值都在瞬间复制到内存中。
所以 j 循环变成这样1:
Dim j As Long
For j = 2 To lastData
If tempProj = sheetData(j, 10) And sheetData(j, 5) = 55 Then
tempTerms = tempTerms + sheetData(j, 8)
End If
Next j
现在我明白你在做什么了。 uniqueArray 就是你的 return 值！仅通过查看方法的签名很难分辨 - 将其命名为 result 或更好的 outHoursPerTerm 将大大有助于使代码更容易一目了然地理解。
考虑将 Application.Cursor 设置为沙漏，完成后将其设置回默认值 - 也可能将状态栏设置为 "Please wait..." 或类似的东西。 如果事情花费的时间超过 5-8 秒，然后考虑为外循环的每几次迭代更新状态栏，但请注意做这将使过程相当慢。
切换计算、工作表事件、屏幕更新和诸如此类的东西，在这里没有帮助 - 你不是在任何地方写，只是阅读。使用内存中的二维数组，您应该会看到相当大的性能改进。
这个答案故意读起来像 Code Review 答案。有关改进工作代码（性能、可读性等）的问题通常更适合 CR。下次您需要帮助改进您的工作代码时考虑在 CR 上询问 - 因为您可以看到 CR 答案比典型的 SO 答案涵盖更多领域。
1未测试，写在答案框里。可能需要将行转置为列。
将 180K 行加载到数组中，必须对 180K 数组进行排序，然后对排序后的数组进行二进制搜索。
外循环每次迭代使用匹配行的memo，匹配完成后停止内循环条件测试。轻松进行界面更新。
每次外部迭代的 Doevents 都足够了。下面只是一些足够的函数：
Option Explicit
Sub getHours()
Dim arr1 As Variant, arr2 As Variant
arr1 = Sheet1.Range("A2:B9001").Value2
arr2 = Sheet2.Range("A2:J180001").Value2 'whatever your range is
QuickSort1 arr2, 10 'sorting data on column 10 as you had it.
Dim i As Long, j As Long, tempSum As Long
For i = 1 To UBound(arr1)
tempSum = 0
Dim retArr As Variant
retArr = wsArrayBinaryLookup(arr1(i, 1), arr2, 10, 10, False)
If Not IsError(retArr(0)) Then
If arr1(i, 1) = retArr(0) Then
Dim matchRow As Long
matchRow = retArr(1)
'Go through from matched row till stop matching
Do
If arr2(matchRow, 10) <> arr1(i, 1) Then Exit Do
If arr2(matchRow, 5) = 55 Then
tempSum = tempSum + arr2(matchRow, 8)
End If
matchRow = matchRow + 1
Loop While matchRow <= UBound(arr2)
End If
End If
arr1(i, 2) = tempSum
DoEvents
Next i
Sheet1.Range("A2:B9001").Value2 = arr1
End Sub
Public Sub QuickSort1( _
ByRef pvarArray As Variant, _
ByVal colToSortBy, _
Optional ByVal plngLeft As Long, _
Optional ByVal plngRight As Long)
Dim lngFirst As Long
Dim lngLast As Long
Dim varMid As Variant
Dim varSwap As Variant
If plngRight = 0 Then
plngLeft = LBound(pvarArray)
plngRight = UBound(pvarArray)
End If
lngFirst = plngLeft
lngLast = plngRight
varMid = pvarArray((plngLeft + plngRight) \ 2, colToSortBy)
Do
Do While pvarArray(lngFirst, colToSortBy) < varMid And lngFirst < plngRight
lngFirst = lngFirst + 1
Loop
Do While varMid < pvarArray(lngLast, colToSortBy) And lngLast > plngLeft
lngLast = lngLast - 1
Loop
Dim arrColumn As Long
If lngFirst <= lngLast Then
For arrColumn = 1 To UBound(pvarArray, 2)
varSwap = pvarArray(lngFirst, arrColumn)
pvarArray(lngFirst, arrColumn) = pvarArray(lngLast, arrColumn)
pvarArray(lngLast, arrColumn) = varSwap
Next arrColumn
lngFirst = lngFirst + 1
lngLast = lngLast - 1
End If
Loop Until lngFirst > lngLast
If plngLeft < lngLast Then QuickSort1 pvarArray, colToSortBy, plngLeft, lngLast
If lngFirst < plngRight Then QuickSort1 pvarArray, colToSortBy, lngFirst, plngRight
End Sub
Public Function wsArrayBinaryLookup( _
ByVal val As Variant, _
arr As Variant, _
ByVal searchCol As Long, _
ByVal returnCol As Long, _
Optional exactMatch As Boolean = True) As Variant
Dim a As Long, z As Long, curr As Long
Dim retArr(0 To 1) As Variant
retArr(0) = CVErr(xlErrNA)
retArr(1) = 0
wsArrayBinaryLookup = retArr
a = LBound(arr)
z = UBound(arr)
If compare(arr(a, searchCol), val) = 1 Then
Exit Function
End If
If compare(arr(a, searchCol), val) = 0 Then
retArr(0) = arr(a, returnCol)
retArr(1) = a
wsArrayBinaryLookup = retArr
Exit Function
End If
If compare(arr(z, searchCol), val) = -1 Then
Exit Function
End If
While z - a > 1
curr = Round((CLng(a) + CLng(z)) / 2, 0)
If compare(arr(curr, searchCol), val) = 0 Then
z = curr
retArr(0) = arr(curr, returnCol)
retArr(1) = curr
wsArrayBinaryLookup = retArr
End If
If compare(arr(curr, searchCol), val) = -1 Then
a = curr
Else
z = curr
End If
Wend
If compare(arr(z, searchCol), val) = 0 Then
retArr(0) = arr(z, returnCol)
retArr(1) = z
wsArrayBinaryLookup = retArr
Else
If Not exactMatch Then
retArr(0) = arr(a, returnCol)
retArr(1) = a
wsArrayBinaryLookup = retArr
End If
End If
End Function
Public Function compare(ByVal x As Variant, ByVal y As Variant) As Long
If IsNumeric(x) And IsNumeric(y) Then
Select Case x - y
Case Is = 0
compare = 0
Case Is > 0
compare = 1
Case Is < 0
compare = -1
End Select
Else
If TypeName(x) = "String" And TypeName(y) = "String" Then
compare = StrComp(x, y, vbTextCompare)
End If
End If
End Function