问题描述
我正在通过 Excel 表 (Listobject) 运行 VBA for each
循环,该表根据给定的路径检查文件是否存在。我的表已经扩展了并且有 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
解决方法
避免访问工作表
- 由于无法避免循环,因此最好在计算机内存中进行,即通过数组的元素而不是通过范围的单元格。
- 代码仍然很慢,我的机器上 20 万行大约需要 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
,
谢谢大家!一些外卖。虽然显然试图编写尽可能高效的代码,但这里任何合理的性能都是可以接受的。话虽如此,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