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

在快速測試這個完成的針對100k的值的表格200K行的查找在剛剛大於3秒以下。

這比你的原始代碼複雜一點，但如果你想優化速度有時是不可避免的。

注：

• 使用腳本字典作爲查找
• 讀/寫所有的值作爲陣列的最大速度

代碼：

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