VBA嵌套循环效率

我正在试图find在VBA中执行任务的最快方法。 目前，我把它写成一个嵌套for循环，可以是非常缓慢的。 我循环了一个唯一的数字列表，并将它们与不同列表中的数字进行匹配。 如果我得到一个匹配，我将信息存储在一个multidimensional array中，因为可以有多个匹配，我想跟踪所有这些。 不幸的是，这意味着当使用for循环，如果只有1000个唯一的数字和5000个数字来寻找匹配我的循环可以最终迭代1000 * 5000 = 5000000次。 正如你所看到的，这可能会很快造成问题。 我问是否有更好的方法来处理这个问题，而留在VBA。 我已经做了所有的窍门，如设置screenUpdating到虚假和计算到manaul。

这是我的代码：

For x = 0 To UBound(arrUniqueNumbers) Dim arrInfo() As Variant ReDim Preserve arrInfo(0) If UBound(arrInfo) = 0 Then arrInfo(0) = CStr(arrUniqueNumbers(x)) End If For y = 2 To Length UniqueString = CStr(arrUniquePhoneNumbers(x)) CLEARString = CStr(Sheets(2).Range("E" & y).Value) If UniqueString = CLEARString Then 'match! NormalizedDate = Format(CStr(Sheets(2).Range("G" & y).Value), "yyyymmdd") z = z + 1 ReDim Preserve arrInfo(z) arrInfo(z) = NormalizedDate & " " & LTrim(CStr(Sheets(2).Range("D" & y).Value)) arrInfo(z) = LTrim(arrInfo(z)) End If Next arrUniqueNumbers(x) = arrInfo() ReDim arrInfo(0) 'erase everything in arrOwners z = 0 Next 

Answer 1

这个循环效率很低，所以有很多可以避免的瓶颈（大多数情况下是按照最简单的方式改变到最复杂的变化）

1. 从最里面的循环中取出UniqueString步骤：这个步骤不会随着y改变而改变，所以没有必要重复它。
2. 将Redim Preserve从最内层的循环中取出：您正在重新分配内层循环中非常低效的内存。 在循环之外分配“足够”的内存量。
3. 不要继续使用Sheets().Range()来访问单元格内容：每次访问电子表格中的内容时，这是一个巨大的拖动，并且与访问有很多相关的开销。 考虑电子表格中的一步式读取操作，然后将操作一步一步地推回到电子表格中以获得结果。 看下面的示例代码。

用于电子表格的高效提取和回推操作的示例代码：

 Dim VarInput() As Variant Dim Rng As Range ' Set Rng = whatever range you are looking at, say A1:A1000 VarInput = Rng ' This makes VarInput a 1 x 1000 array where VarInput(1,1) refers to the value in cell A1, etc. ' This is a ONE STEP fetch operation ' Your code goes here, loops and all Dim OutputVar() as Variant Redim OutputVar(1 to 1000, 1 to 1) ' Fill values in OutputVar(1,1), (1,2) etc. the way you would like in your output range Dim OutputRng as Range Set OutputRng = ActiveSheet.Range("B1:B1000") ' where you want your results OutputRng = OutputVar ' ONE STEP push operation - pushes all the contents of the variant array onto the spreadsheet 

还有其他几个步骤可以进一步显着加快你的代码的速度，但是这些步骤应该不会造成太大的影响。

Answer 2

 dim dict as Object set dict = CreateObject("Scripting.Dictionary") dim x as Long 'Fill with ids 'Are arrUniqueNumbers and arrUniquePhoneNumbers the same? For x = 0 To UBound(arrUniqueNumbers) dict.add CStr(arrUniquePhoneNumbers(x)), New Collection next 'Load Range contents in 2-Dimensional Array dim idArray as Variant idArray = Sheets(2).Cells(2,"E").resize(Length-2+1).Value dim timeArray as Variant timeArray = Sheets(2).Cells(2,"G").resize(Length-2+1).Value dim somethingArray as Variant somethingArray = Sheets(2).Cells(2,"D").resize(Length-2+1).Value dim y as Long 'Add Values to Dictionary For y = 2 To Length Dim CLEARString As String CLEARString = CStr(timeArray(y,1)) If dict.exists(CLEARString) then dict(CLEARString).Add LTrim( Format(timeArray(y,1)), "yyyymmdd")) _ & " " & LTrim(CStr(somethingArray(y,1))) end if next 

像这样访问

 dim currentId as Variant for each currentId in dict.Keys dim currentValue as variant for each currentValue in dict(currentId) debug.Print currentId, currentValue next next