Excel 在执行循环时停止响应

Question

下面代码中的 ws1lastrow 值为 147583

我正在从 VB 编辑器中执行以下代码。Debug.print 用于跟踪已处理的行。ws1lastrow 值为 147583

执行到 5000 或 6000（每次计数更改时）后，Excel 停止响应，我必须重新启动并运行。

发生这种情况的任何原因以及处理此问题的任何解决方案/提示？

 
   子标识MissingsNew()
    将 ws1 调暗为工作表
    将 rws 变暗为工作表
    Set ws1 = ThisWorkbook.Sheets("New")
    Set rws = ThisWorkbook.Sheets("DelInt")
    ws1lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    设置lookuprange = rws.Range("a1").CurrentRegion
    对于 i = 2 到 ws1lastrow
    ws1.Cells(i, "ae") = Application.VLookup(ws1.Cells(i, "a"), lookuprange, 3, False)
    调试.打印我
    接下来我
    结束子

Answer 1

在快速测试中，这在不到 3 秒的时间内完成了对 100k 值表的 200k 行的查找。

它比您的原始代码稍微复杂一些，但是如果您想优化速度，这有时是不可避免的。

笔记：

• 使用脚本字典作为查找
• 将所有值作为数组读/写以获得最大速度

代码：

 Sub IdentifyMissingsNew()

    Dim ws1 As Worksheet
    Dim rws As Worksheet, t, arr1, arr2
    Dim dict As Object, rw As Range, res(), arr, nR As Long, i As Long

    Set ws1 = ThisWorkbook.Sheets("New")
    Set rws = ThisWorkbook.Sheets("DelInt")
    Set dict = CreateObject("scripting.dictionary")

    t = Timer

    'create a lookup from two arrays
    arr1 = rws.Range("a1").CurrentRegion.Columns(1).Value
    arr2 = rws.Range("a1").CurrentRegion.Columns(3).Value
    For i = 2 To UBound(arr1, 1)
        dict(arr1(i, 1)) = arr2(i, 1)
    Next i

    Debug.Print "created lookup", Timer - t

    'get the values to look up
    arr = ws1.Range(ws1.Range("A2"), ws1.Cells(Rows.Count, 1).End(xlUp))
    nR = UBound(arr, 1)        '<<number of "rows" in your dataset
    ReDim res(1 To nR, 1 To 1) '<< resize the output array to match

    'perform the lookup
    For i = 1 To nR
        If dict.exists(arr(i, 1)) Then
            res(i, 1) = dict(arr(i, 1))
        Else
            res(i, 1) = "No match!"
        End If
    Next i

    ws1.Range("AE2").Resize(nR, 1).Value = res '<< populate the results

    Debug.Print "Done", Timer - t

End Sub