Excel 在执行循环时停止响应

Question

下面代码中的ws1lastrow值为147583

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

执行到 5000 或 6000 后(每次计数发生变化)，Excel 停止响应，我必须重新启动并运行。

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

    Sub IdentifyMissingsNew()    Dim ws1 As Worksheet    Dim rws As Worksheet    Set ws1 = ThisWorkbook.Sheets("New")    Set rws = ThisWorkbook.Sheets("DelInt")    ws1lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row    Set lookuprange = rws.Range("a1").CurrentRegion    For i = 2 To ws1lastrow    ws1.Cells(i, "ae") = Application.VLookup(ws1.Cells(i, "a"), lookuprange, 3, False)    Debug.Print i    Next i    End Sub

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