每个循环的 VBA 具有 64K+ ListRows（ouf 内存）

Question

我正在通过 Excel 表（Listobject）运行 VBA

for each

循环，该循环根据给定路径检查文件是否存在。我的表已经扩展并且有 68K 列表行。启动代码后，很快就报错了

Run-time-error '7': Out of memory

它可以正常运行 63K 行（5 分钟内完成），并且根据谷歌搜索，似乎存在所谓的“64K 段边界”。这是影响我的代码运行的原因吗，因为它确实感觉它首先缓冲了行计数，然后反弹回来而没有开始实际运行任何东西。是否有一个简单的解决方法，无需将我的数据集分成多个批次？坦率地说，我很惊讶 2021 年 Excel 中仍然存在 64K 限制。

在 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

避免访问工作表

• 由于无法避免循环，因此最好在计算机内存中进行循环，即通过数组的元素而不是范围的单元格。
• 代码仍然很慢，在我的机器上大约需要 10 秒才能处理 200k 行，但那是因为

  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

Answer 2

谢谢大家！一些要点。虽然显然试图编写尽可能高效的代码，但这里任何合理的性能都是可以接受的。话虽如此，

for each

循环需要大约 5 分钟才能运行 63K 行，同时，我接受的 @VBasic2008 作为答案的代码在大约 15 秒内完成了 - 也没有容量问题。

我对这个特定代码的唯一问题是它对我来说有点新的方法，所以将来可能需要一些奉献精神来更深入地研究它 - 但它看起来确实很有效。我还组合了一个常规的

for ... to

循环，该循环也不会遇到 68K 行的问题，并且可以使用

offset

函数在行和列之间进行引导。

明显比 @Pᴇʜ 建议的

for each

快，但花费的时间大约是数组方法的 2 倍（30 秒左右）。

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