VBA for each loop with 64K+ ListRows (ouf of memory)

user_7354851 0
Viewed 309

I'm running a VBA for each loop through an Excel table (Listobject) which checks if a file exists based on a given path. My table has expanded though and has 68K Listrows. After launching the code, it quickly gives an error Run-time-error '7': Out of memory

It runs OK with 63K lines (done within 5 minutes) and based on googling there appears to be something called "64K segment boundary". Is this what's affecting my code to run since it really feels like it buffers the row count at first and then bounces back w/o starting to actually run anything. Is there an easy workaround for this without the need to split up my dataset into multiple batches? Frankly, I was quite surprised that 64K limits would still be a thing in Excel in 2021.

Running it on 64bit Excel 2019, but no luck with Office365 either.

Sub CheckFiles()

Dim Headers As ListObject
Dim lstrw As ListRow

Dim strFileName As String
Dim strFileExists As String

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")

    For Each lstrw In Headers.ListRows
    
        strFileName = lstrw.Range(7)
        strFileExists = Dir(strFileName)
        
        If strFileExists = "" Then
        lstrw.Range(4) = "not found"
        Else
        lstrw.Range(4) = "exists"
        End If
    
    Next lstrw

Set ws = Nothing
Set Headers = Nothing

Application.ScreenUpdating = True

End Sub
vba excel foreach
2 Answers

Avoid Accessing the Worksheet

  • Since you cannot avoid looping, you better do it in the computer's memory, i.e. rather through the elements of an array than through the cells of a range.
  • The code is still slow, about 10s for 200k rows on my machine, but that's because of Dir.
  • Note how easy (one line only, when the range contains more than one cell) and how fast (a split second) it is to write (copy) a range to an array (Data = rg.Value) and write (copy) the array back to a range (rg.Value = Data).
  • Adjust the values in the constants section.
Option Explicit

Sub CheckFiles()

    Const wsName As String = "Import" ' Worksheet Name
    Const tblName As String = "Import" ' Table Name
    Const cCol As Long = 7 ' Criteria Column
    Const dCol As Long = 4 ' Destination Column

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim Headers As ListObject: Set Headers = ws.ListObjects(tblName)

    Dim Data As Variant ' Data Array
    With Headers.ListColumns(cCol).DataBodyRange
        If .Rows.Count = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data = .Value
        Else
            Data = .Value
        End If
    End With
    
    Dim r As Long ' Array Row Counter (DataBodyRange Row Counter)
    Dim FileName As String ' File Name Retrieved by Dir
    
    For r = 1 To UBound(Data, 1)
        FileName = Dir(CStr(Data(r, 1)))
        If Len(FileName) = 0 Then
            Data(r, 1) = "not found"
        Else
            Data(r, 1) = "exists"
        End If
    Next r
    
    Headers.ListColumns(dCol).DataBodyRange.Value = Data

End Sub
user_98140690

Thank you all! A few takeaways. While obviously trying to write as efficient code as possible, any reasonable performance here is acceptable. With that said, for each loop took approx 5 minutes to run with 63K lines, meawhile it was done in about 15 seconds by the code I accepted as an answer by @VBasic2008 - without capacity problems either.

The only problem I had with this particular code was it being somewhat new approach for me, so possibly building on it in the future needs some dedication in looking deeper into it - but it sure looks efficient. I also put together a regular for ... to loop which also didn't run into problems with 68K lines and would steer between rows and columns with offset function.

Clearly faster than for each as @Pᴇʜ suggested but took approx 2x as long as the array method (30 seconds or so).

Sub CheckFiles_2()

Dim strFileName, strFileExists As String
Dim ws As Worksheet

Dim Headers As ListObject
Dim result As String
Dim counter, RowCount As Long

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")

RowCount = Headers.ListRows.Count

For counter = 1 To RowCount

strFileName = Range("anchorCell").Offset(counter, 3)

        strFileExists = Dir(strFileName)
        
        If strFileExists = "" Then
        result = "not found"
        Else
        result = "exists"
        End If

Range("anchorCell").Offset(counter, 0) = result

Next counter

Set ws = Nothing
Set Headers = Nothing

Application.ScreenUpdating = True

End Sub
user_73548510
Related