循环复制4000+工作簿的VBA宏内存占用超1.5GB问题排查

我有一定编程基础但非专业开发者，写了个VBA宏用来把子文件夹里的所有工作簿数据聚合到单张工作表，通过公式从关闭的工作簿提取A3:AO10这类大区域的数据。

宏通过以下循环遍历子文件夹与文件：

For Each dFolder In fso.GetFolder(contractFolderPath).SubFolders

For Each cFile In dFolder.Files

排除非Excel文件后，调用ReadContract函数：

sucess = ReadContract(cFile.ParentFolder.Path & Application.PathSeparator, cFile.ShortName, dWorkbook) 

dWorkbook由独立函数创建，每处理完一个子文件夹的所有文件后，dWorkbook会保存并关闭。宏可成功处理4200个文件，但运行中内存持续增长，临近结束时达1.5GB，导致运行速度下降。

我疑惑的是：退出函数后内存未释放？处理后的目标工作簿已保存关闭，39个目标工作簿仅占68MB磁盘空间，源文件单份2.8MB但未打开仅通过公式提取数据，变量生命周期结束后内存应回收，想问问代码是否存在问题导致内存占用过高。

附ReadContract函数代码：

Function ReadContract(cPath As String, cFile As String, ByRef dWorkbook As Workbook) As Boolean 'dWorkbook As Workbook
On Error GoTo NoSheetInFile
    Dim lRowUsed     As Integer
    'Dim HasSheet     As Variant
    Dim dynamicRange As String
    Dim contractCheck As Variant
    Dim commaInName As Integer
    Dim splitName As Variant
    Dim formula As String

    ' 检查源工作簿中是否存在"Auslesen"工作表
    contractCheck = CheckSheetExists(cPath, cFile, nameSheet)

    If contractCheck = False Then '若工作表不存在，结束函数并处理下一个文件
    
        ReadContract = False
        Exit Function
    
    End If

    ' 获取目标工作簿已用数据的最后一行
    lRowUsed = dWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 生成动态目标区域，从已用行的下一行开始
    dynamicRange = "A" & lRowUsed + 1 & ":" & maxCol & lRowUsed + rowsToRead
    
    commaInName = InStr(1, cFile, "'", vbTextCompare)

    If commaInName <> 0 Then
    
        splitName = Split(cFile, "'", -1, vbTextCompare)
        
        formula = "='" & cPath & "[" & splitName(0) & "''" & splitName(1) & "]" & nameSheet & "'!" & sCell & ""
    
    Else
    
        ' 从关闭的源工作簿提取数据的公式
        formula = "='" & cPath & "[" & cFile & "]" & nameSheet & "'!" & sCell & ""
    
    End If
    
        With dWorkbook.Sheets(1).Range(dynamicRange)
            .formula = formula
            .Value = .Value ' 将公式转为值
        End With
        
    Call CleanUp(lRowUsed, dWorkbook) '清理不需要的行，一次性复制比单独复制零散行更高效
    
    ' 执行到此处说明成功
    ReadContract = True
    Exit Function
NoSheetInFile:
ReadContract = False
    
End Function

内存增长的核心原因及修复方案 #

1. 外部公式缓存残留
   即使把公式转成值，Excel解析外部工作簿公式时会临时加载源文件元数据到内存，大量处理后缓存会累积。

   • 修复：在公式转值的With块后添加代码清除残留痕迹：

     .ClearComments ' 清除可能附带的注释缓存
     

     每个子文件夹处理完、关闭dWorkbook后，强制刷新计算链清理无效引用：

     Application.CalculateFullRebuild
     

2. 变量未显式释放+错误处理遗漏

   • splitName作为数组变量，大量循环下建议显式清空，在ReadContract = True前添加：

     Erase splitName
     

   • 错误处理块未清理变量，若中途出错会导致临时对象滞留，修改错误块：

NoSheetInFile:
On Error Resume Next
Erase splitName
ReadContract = False
```

3. FSO对象未销毁
   遍历完所有文件夹后，显式释放FSO对象：

Set fso = Nothing

4. **自动计算与屏幕刷新拖慢并占用内存**
宏开头添加以下代码关闭不必要的后台操作：
```vba
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

宏结束或出错时恢复设置：

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

5. CleanUp函数的潜在泄漏
   检查CleanUp函数，确保所有Range等对象变量都显式设置为Nothing，避免内存滞留。

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