Excel在执行循环时停止响应

Question

 
   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行的查找。

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

备注：

null

 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