加快arrayssearch，如果可能的话可能是2D集合？
我需要一些帮助来加速当前正在运行的代码。
首先，我有一个大的data表，它有大约180,000行，并且有一个unique表格，它只有来自大表的唯一值，大约是9000行，所以现在需要很长时间才能使这个代码可行。 当前的i和j值只是占位符来testing代码是否工作。
我的想法是创build一个集合来存储数据，以便一旦匹配，就可以将它从集合中删除，所以以后不需要再次检查uniqueArray()中的另一个值。
是否可能收集，因为在添加第4个单元格的值之前，我需要检查3个条件？
我真的很感激任何帮助或build议，因为我真的只在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
将180K行加载到数组中，必须对180K数组进行sorting，然后对该sorting数组进行二分search。
对外循环的每个迭代使用匹配行的备注，一旦匹配完成，就停止对内循环的条件进行testing。 在界面更新上轻松点击。
每个外迭代中的doevents都可以通过。 下面是一些足够的function：
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
Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
该过程含义是Public ，并且参数隐式地传递给ByRef 。 作为一个维护者，我期望一个名为getHours的方法让我获得“小时”，不pipe是什么 – 但是一个Sub过程不会返回任何东西给它的调用者，就像一个Function那样。 因此这个名字是误导性的。 程序做了一些事情，他们需要一个描述性的名字来说明它的作用，然后代码需要做这个名字所说的。
一致性也很重要：您有一个camelCase公用过程名称，然后混合使用camelCase和PascalCase参数名称。 坚持PascalCase模块成员，并使用camelCase本地/参数。 或者什么 – 只要保持一致 。
LastRow是一个Integer引发一个标志。 Integer是一个16位有符号整数types，使其最大值为32,767，当您尝试将其分配到32,768或更高时，将导致问题。 使用Long整型 – 32位有符号整数types更适合于通用整数值 – 特别是像“行号”，在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")
请注意，不受Worksheet对象限制的Range隐式引用任何工作表处于活动状态的工作簿。 除非你在工作表模块的代码隐藏 – 在这种情况下，它是指该工作表。 如果你的意思是做到这一点，请明确，并做Me.Range 。 如果不是，则使用Worksheet对象正确限定Range和Cells调用。
然后使用它：
lastData = dataSheet.Range("A2").End(xlDown).Row
更多整数：
Dim tempTerms As Integer
同样，没有理由使用16位整数types，声明As Long 。
Dim OpenForms
这个程序需要知道打开表单的数量是多less？ 它不。 去掉它。
openform = DoEvents
您正在分配给openform ，但是您声明了OpenForms 。 如果您的代码编译并运行，这意味着您没有在模块的顶部指定Option Explicit 。 这样做。 这将阻止VBA愉快地编译拼写错误，并会强制您声明您使用的每个variables。 在这里， OpenForms被使用，而openform是一个由VBA运行时声明的未声明的Variant 。
说实话，我甚至都不知道DoEvents返回了任何东西 – 它返回的开放表单的数量让我觉得这是一个巨大的WTF。 无论如何，这是我一直看到它使用的方式：
DoEvents
就这样！ 是的，这丢弃了返回的值。 但是，首先关心打开表格的人数呢？
tempProj没有声明。 申报。 j没有声明。 申报。
读取单元格的值是危险的。 单元格包含Variant ，所以无论何时将单元格的值读入String或Long或任何types的variables，都会使VBA执行隐式types转换 – 这种转换并非总是可行。
这最终会打破 – 或者在这个或另一个项目中回来咬你
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
好的，那么表演呢？
- 当存在更好的types时避免
Variant。 - 避免未申报的变数; 他们总是
Variant。 使用Option Explicit。 - 避免隐式types转换。
- 避免
Select和Activate。 - 避免
DoEvents。 - 避免更新UI（状态栏等）。
- 避免在循环中访问工作表单元格。
将工作表的数据读入一个variables数组：
Dim dataSheet As Worksheet Set dataSheet = ThisWorkbook.Worksheets("Data") Dim sheetData As Variant sheetData = dataSheet.Range("A1:J" & lastData).Value
现在sheetData是一个二维数组，它包含了指定范围内的每一个值 – 全部都是在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是你的回报价值！ 很难通过查看方法的签名来说明 – 命名它的result或更好， outHoursPerTerm将outHoursPerTerm代码的一目了然。
考虑将Application.Cursor设置为沙漏，并在完成后将其设置为默认值 – 也可能将状态栏设置为“Please wait …”或类似的内容。 如果事情花费的时间超过了5到8秒， 那么考虑更新每个外环的几次迭代的状态栏，但是请注意，这样做会使程序相当慢。
切换计算，工作表事件，屏幕更新和whatnot，是不会在这里帮助 – 你不写在任何地方，只有阅读。 解决内存中的二维数组，你应该看到很大的性能提升。
这个答案故意读取像一个代码审查答案。 有关改进工作代码（性能，可读性等）的问题通常更适合于CR。 考虑下一次你需要帮助改善你的工作代码问CR – 正如你可以看到一个CR答案涵盖比典型的答案更多的地面。
1未经testing，写在答案框中。 可能需要将行转换为列。
这是我通常用来加速的：
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定义为某种东西。