VBA处理数万行Excel报内存不足 运行至2.5万行崩溃排查

我编写了如下VBA代码用于处理包含数万行数据的电子表格：代码运行时单看行处理速度不算慢，1万行数据大概3-4分钟能跑完，但每次运行到2.5万行左右程序就会崩溃，弹出「内存不足，无法完成此操作」的提示，同时建议升级到64位Office。我之前写过逻辑更复杂的宏生成这张工作表，全程运行没有异常，所以这次的崩溃情况很反常，想确认代码里是否存在导致内存问题的写法，还是说升级64位版本才是正确解决方案。

附问题代码 #

Sub TPOUploadCADUplicate()
'This takes the TPO Mass upload sheet and duplicates it below for Canada. Unlike above, it doesn't do anything to the US part on top
Dim Answer As String
Dim BigMarkup As Double
Dim CAPrice As Double
Dim Cost As Double
Dim i As Long
Dim rn As Long
Dim rn2 As Long
Dim SKUCount As Double
Dim STMarkup As Double
Dim USPrice As Double
Dim lr As Long
Dim DescLen As Integer

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

'Make sure you didn't accidentally leave the description length column in
If Cells(1, 3) <> "VENDOR # (9 SPACES)" Then
    DescLen = MsgBox("Yo, bro. I think you left the description length column in. You want to delete that shit? I can't proceed otherwise.", vbYesNo)
    If DescLen = 6 Then
        Columns(3).Delete
    ElseIf DescLen = 7 Then
        Exit Sub
    End If
End If

Columns(6).NumberFormat = "#.00"
'Loop through each one, doing the math from the TPO price calculator Connie has
If Cells(2, 1) = "" Then Exit Sub
rn = Cells(1, 1).End(xlDown).Row

rn2 = rn + 1
rn = 2
SKUCount = rn2 - rn
For i = 1 To SKUCount
    Application.StatusBar = "Progress: " & i & " of " & SKUCount & " - " & Format(i / SKUCount, "0%")
    Rows(rn2).Value = Rows(rn).Value
    USPrice = Cells(rn, 4)
    If USPrice * CAMarkup < 20 Then
        CAPrice = Round((USPrice) * CAMarkup, 1) + 0.09
    Else
        CAPrice = WorksheetFunction.RoundDown((USPrice) * CAMarkup, 0) + 0.99
    End If

    Cells(rn2, 4) = CAPrice
    Cells(rn2, 6).Value = Cells(rn2, 6).Value * CAMarkup
    Cells(rn2, 22) = "CAM"
    rn = rn + 1
    rn2 = rn2 + 1

Next i

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With

End Sub

崩溃和是否升级64位Office没有直接关系，核心是代码写法导致内存持续占用无法释放，累计到2.5万行左右就触碰到32位Office单进程约2GB的内存上限。之前逻辑更复杂的宏没有崩溃，大概率是用了批量读写逻辑或者中途触发了内存回收，和代码逻辑复杂度无关。
具体问题点：

• 循环内逐行、逐单元格读写的操作，会持续向Excel的撤销栈写入操作记录，几万次操作下来撤销栈会占满绝大多数可用内存，这是VBA处理大表时最常见的内存溢出诱因。
• 代码全程没有显式指定操作的工作表对象，直接调用Cells/Rows/Columns属于隐式引用活动表，不仅容易写错数据，还会产生额外的内存开销；另外代码中用到的CAMarkup变量没有提前定义，会被默认识别为变体类型，也会带来不必要的内存占用。

不要逐行读写单元格，改用数组将所有待处理数据一次性读入内存，计算完成后一次性写回工作表，同时补上缺失的变量定义、显式绑定工作表对象，处理速度会提升数十倍，也不会触发内存溢出。参考修改代码如下：

Option Explicit ' 强制变量声明，避免漏定义变量的问题
Sub TPOUploadCADUplicate()
    ' 请将CAMarkup的值替换为你实际使用的加拿大区加价系数
    Const CAMarkup As Double = 1.3
    Dim ws As Worksheet
    Dim lastRow As Long, skuCount As Long
    Dim sourceArr As Variant, targetArr As Variant
    Dim i As Long, col As Long
    
    ' 显式指定要操作的工作表，请替换为你实际的表名
    Set ws = ThisWorkbook.Worksheets("TPO Mass Upload")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    ' 校验第三列表头
    If ws.Cells(1, 3) <> "VENDOR # (9 SPACES)" Then
        Select Case MsgBox("检测到可能残留的描述长度列，是否删除该列后继续？", vbYesNo)
            Case vbYes: ws.Columns(3).Delete
            Case vbNo: GoTo CleanExit
        End Select
    End If
    
    ws.Columns(6).NumberFormat = "#.00"
    If ws.Cells(2, 1) = "" Then GoTo CleanExit
    
    lastRow = ws.Cells(1, 1).End(xlDown).Row
    skuCount = lastRow - 1
    ' 一次性将所有源数据读入内存数组
    sourceArr = ws.Range("A2:V" & lastRow).Value
    ' 初始化加拿大区数据的存储数组
    ReDim targetArr(1 To skuCount, 1 To UBound(sourceArr, 2))
    
    For i = 1 To skuCount
        ' 每处理1000行更新一次进度条，避免频繁刷新状态栏拖慢速度
        If i Mod 1000 = 0 Then Application.StatusBar = "处理进度: " & Format(i / skuCount, "0%")
        ' 复制源行的所有列数据
        For col = 1 To UBound(sourceArr, 2)
            targetArr(i, col) = sourceArr(i, col)
        Next
        ' 计算加拿大区售价
        If sourceArr(i, 4) * CAMarkup < 20 Then
            targetArr(i, 4) = Round(sourceArr(i, 4) * CAMarkup, 1) + 0.09
        Else
            targetArr(i, 4) = WorksheetFunction.RoundDown(sourceArr(i, 4) * CAMarkup, 0) + 0.99
        End If
        ' 调整第6列对应价格
        targetArr(i, 6) = sourceArr(i, 6) * CAMarkup
        ' 标记区域字段为CAM
        targetArr(i, 22) = "CAM"
    Next i
    
    ' 一次性将所有计算完成的加拿大区数据写入原数据下方
    ws.Range("A" & lastRow + 1).Resize(skuCount, UBound(targetArr, 2)).Value = targetArr

CleanExit:
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .StatusBar = False
    End With
End Sub

补充：只有当你经常需要处理单表几十万行以上的数据时，升级64位Office才有实际意义。常规几万行规模的数据，用数组批量处理的写法在32位Office下完全可以流畅运行，不会出现内存不足的问题。

内容的提问来源于stack exchange，提问作者Gary Nolan