Excel执行循环时停止响应

下面代码中的ws1lastrow值是147583

我在VB编辑器中执行下面的代码。 Debug.print用于保持已处理行的轨迹。 ws1lastrow值是147583

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

为什么会发生这种情况的任何原因，以及处理这个问题的解决scheme/技巧

 
    Sub IdentifyMissingsNew（）
    昏暗的ws1作为工作表
    昏暗rws作为工作表
    设置ws1 = ThisWorkbook.Sheets（“新build”）
    设置rws = ThisWorkbook.Sheets（“DelInt”）
     ws1lastrow = ws1.Cells（Rows.Count，1）.End（xlUp）.Row
    设置lookuprange = rws.Range（“a1”）。CurrentRegion
    对于我= 2到ws1lastrow
     ws1.Cells（i，“ae”）= Application.VLookup（ws1.Cells（i，“a”），lookuprange，3，False）
     Debug.Print i
    接下来我
    结束小组

Answer 1

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

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

笔记：

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

码：

  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