Excel stops responding while executing loop

Question

ws1lastrow value in the code below is 147583

I am executing the code below from within the VB Editor. Debug.print is used to keep a track of rows processed. ws1lastrow value is 147583

After executing till 5000 or 6000 (every time the count changes), the Excel stops responding and I have to restart and run.

Any reason why this happens and any solutions/tips for handling this?

 
   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

Excel may have stopped responding to you, but it is almost certainly still running. Adding a DoEvents after your Debug.Print i will probably allow it to continue responding. But you should consider rewriting the code so that it isn't so slow. — YowE3K

Tim Williams Tim Williams · Accepted Answer · 2017-08-30T05:36:39

In a quick test this completed a lookup of 200k rows against a table of 100k values in just less than 3 sec.

It's a bit more complex than your original code, but if you want to optimize for speed that's sometimes unavoidable.

Notes:

use a scripting dictionary as a lookup
read/write all values as arrays for maximum speed

Code:

 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 stops responding while executing loop

1 Answers