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

Excel在执行循环时停止响应

1 个答案: