excel - 具有 64K+ ListRows 的每个循环的 VBA(内存不足)

Question

我正在运行 VBA for each循环遍历 Excel 表 (Listobject)，该表根据给定路径检查文件是否存在。我的表已经扩展，并且有 68K 列表行。启动代码后，很快报错Run-time-error '7': Out of memory它运行正常，有 63K 行(在 5 分钟内完成)，根据谷歌搜索，似乎有一种叫做“64K 段边界”的东西。这是什么影响了我的代码运行，因为它真的感觉它首先缓冲了行数，然后在没有开始实际运行任何东西的情况下反弹回来。是否有一个简单的解决方法，无需将我的数据集分成多个批处理？坦率地说，我很惊讶 64K 限制在 2021 年仍然存在于 Excel 中。
在 64 位 Excel 2019 上运行它，但在 Office365 上也没有运气。

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

Answer 1

避免访问工作表

由于无法避免循环，因此最好在计算机的内存中进行，即通过数组的元素而不是通过范围的单元格。

代码仍然很慢，我的机器上 200k 行大约需要 10 秒，但这是因为 Dir .

请注意将范围写入(复制)到数组( Data = rg.Value )并将数组写回(复制)有多容易(仅一行，当范围包含多个单元格时)以及多快(一瞬间)到一个范围(rg.Value = Data)。

调整常量部分中的值。

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