Excel VBA数组迁移大数据：如何排查内存泄漏问题？

问题场景 #

需要迁移22000行×36列的大数据，手动复制粘贴会导致Excel崩溃，因此编写了数组迁移宏，但运行时触发Error 7（内存不足），通常处理到第1600行左右报错。宏核心逻辑为：

• 将选中数据存入数组arrSrcData
• 循环将数组中两行数据复制到临时数组
• 写入目标ListObject表格
• 重复上述步骤

原代码如下：

Public Sub copy_paste_data()

    ' Select Copy from and copy to ranges (rngDest just needs to be a single cell)
    Set rngSrc = Application.InputBox("Select full range of data that you would like to copy. Include header row.", "Range of Data to Copy", Type:=8)
    Set rngDest = Application.InputBox("Select any cell in table where you would like to paste", "Any Cell of Table to Paste in", Type:=8)
      
    ' Convert ranges to arrays
    Set tblDest = rngDest.ListObject
    arrSrcHeaders = rngSrc.Rows(1).Value2
    arrSrcData = rngSrc.Rows(2 & ":" & rngSrc.Rows.Count).Value2
    arrDestHeaders = tblDest.HeaderRowRange.Value2
    arrDestExampleData = tblDest.DataBodyRange.Rows(1).Value2
    
    ' Turn off Excel features to make Excel run faster for the moving data part of this macro
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Row/Column Counts
    destColCnt = UBound(arrDestHeaders, 2) - LBound(arrDestHeaders, 2) + 1
    srcDataColCnt = UBound(arrSrcData, 2) - LBound(arrSrcData, 2) + 1
    srcDataRowCnt = UBound(arrSrcData, 1) - LBound(arrSrcData, 1) + 1


    With tblDest
        ' delete all but first row of data table before pasting in new data
        If .DataBodyRange.Rows.Count > 1 Then
            .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Delete
        End If
        
        ' row and column bounds calculated here so they don't have to be repeatedly calculated in loop
        srcDataLBound = LBound(arrSrcData, 1)
        srcDataUBound = UBound(arrSrcData, 1)
        srcDataColLBound = LBound(arrSrcData, 2)
        srcDataColUBound = UBound(arrSrcData, 2)
        
        ' ************* Main loop *****************************
        For i = srcDataLBound To srcDataUBound Step 2
            interimRows = Application.WorksheetFunction.Min(2, srcDataUBound - i)
            ReDim arrSrcDataInterim(1 To interimRows, srcDataColLBound To srcDataColUBound)
            For r = 1 To interimRows
                For c = srcDataColLBound To srcDataColUBound
                    arrSrcDataInterim(r, c) = arrSrcData(i + r - 1, c)
                Next c
            Next r
            ' ************************* ERRORS OUT HERE ******************************
            .DataBodyRange.Offset(i - 1, 0).Resize(interimRows, srcDataColCnt).Value2 = arrSrcDataInterim ' ERRORS OUT HERE
            ' ************************* ERRORS OUT HERE ******************************
        Next i
        ' ***************************************************************8
        
        ' resize table listobject
        .Resize Range(.Range(1, 1), .Range(srcDataRowCnt + 1, destColCnt)) ' add 1 to rows to account for header row
        
        ' drag down formulas to the right if need be
        If destColCnt > srcDataColCnt Then
            .DataBodyRange.Cells(1, srcDataColCnt + 1).Resize(srcDataRowCnt, destColCnt - srcDataColCnt).FillDown
        End If
    
    End With
    
CleanupAndExitSub:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

错误原因分析 #

1. 频繁扩展表格：每次写入两行数据时，ListObject会自动扩展表格结构，频繁的结构调整会导致Excel内存占用急剧上升
2. 低效的临时数组复制：循环中反复创建小临时数组并逐单元格复制，增加了不必要的内存开销和运算时间
3. 保留首行数据：目标表格保留了第一行数据，后续写入时会引发额外的行插入/扩展逻辑，加重内存负担

优化方案 #

1. 清空目标表格所有数据行，避免频繁扩展
2. 直接批量写入源数组（或分大批次，如1000行/批），减少表格操作次数
3. 移除不必要的临时数组复制，直接利用源数组切片写入

优化后的代码 #

Public Sub copy_paste_data_optimized()
    Dim rngSrc As Range, rngDest As Range
    Dim tblDest As ListObject
    Dim arrSrcData As Variant
    Dim destColCnt As Long, srcDataColCnt As Long, srcDataRowCnt As Long
    Dim batchSize As Long, i As Long, remainingRows As Long
    
    ' 选择源数据和目标表格
    Set rngSrc = Application.InputBox("选择要复制的完整数据区域（包含表头）", "源数据区域", Type:=8)
    Set rngDest = Application.InputBox("选择目标表格中的任意单元格", "目标表格位置", Type:=8)
    
    Set tblDest = rngDest.ListObject
    ' 仅加载源数据（跳过表头）
    arrSrcData = rngSrc.Offset(1).Resize(rngSrc.Rows.Count - 1).Value2
    
    ' 关闭Excel耗时功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False ' 新增：禁用事件触发，进一步降低负载
    
    ' 计算行列数
    destColCnt = tblDest.HeaderRowRange.Columns.Count
    srcDataColCnt = UBound(arrSrcData, 2)
    srcDataRowCnt = UBound(arrSrcData, 1)
    
    With tblDest
        ' 清空目标表格所有数据行
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.Delete
        End If
        
        ' 设置批次大小（可根据内存调整，建议1000-5000行）
        batchSize = 1000
        
        ' 批量写入数据
        For i = 1 To srcDataRowCnt Step batchSize
            remainingRows = Application.WorksheetFunction.Min(batchSize, srcDataRowCnt - i + 1)
            
            ' 先扩展表格到所需行数
            .ListRows.Add Count:=remainingRows
            
            ' 直接写入源数组切片，无需临时数组
            .DataBodyRange.Offset(i - 1).Resize(remainingRows, srcDataColCnt).Value2 = _
                Application.Index(arrSrcData, Evaluate("row(" & i & ":" & i + remainingRows - 1 & ")"), 0)
        Next i
        
        ' 自动调整表格列数（如果目标列更多）
        .Resize .Range.Resize(srcDataRowCnt + 1, destColCnt)
        
        ' 填充右侧公式
        If destColCnt > srcDataColCnt Then
            .DataBodyRange.Cells(1, srcDataColCnt + 1).Resize(srcDataRowCnt, destColCnt - srcDataColCnt).FillDown
        End If
    End With
    
CleanupAndExitSub:
    ' 恢复Excel功能
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "数据迁移完成", vbInformation
End Sub

优化说明 #

• 批量写入：每次写入1000行（可调整），大幅减少表格扩展次数，降低内存占用
• 直接数组切片：利用Application.Index直接获取源数组的指定行切片，避免逐单元格复制临时数组
• 清空所有数据行：一次性清空目标表格数据，后续统一扩展写入，消除频繁行插入的内存开销
• 禁用事件触发：新增Application.EnableEvents = False，避免表格变化触发不必要的事件（如工作表变更事件）

内容的提问来源于stack exchange，提问作者Zach Engel