VBA创建大量工作簿未关闭致内存不足，求修改代码实现创建后关闭

现有VBA代码用于遍历源工作簿的所有工作表，在A1:O3区域查找单元格末尾括号内的单词，基于该单词创建新工作簿并将匹配的工作表复制到对应工作簿中。但当需要创建175个以上工作簿时，大量工作簿持续处于打开状态会耗尽RAM，导致内存不足。以下是修改后的代码，实现每个工作簿完成复制后立即保存并关闭，释放内存：

修改后的代码 #

Sub SaveSheetsToWorkbooks()
    Dim SourceWorkbook As Workbook
    Dim SourceWorksheet As Worksheet
    Dim SearchRange As Range
    Dim Cell As Range
    Dim TargetWorkbook As Workbook
    Dim regex As Object
    Dim match As Object
    Dim WordToPath As Object ' 存储单词对应的工作簿路径
    Dim TargetPath As String
    Dim BaseSavePath As String
    
    ' 设置源工作簿
    Set SourceWorkbook = ThisWorkbook
    ' 设置保存基础路径（根据实际情况修改）
    BaseSavePath = "C:\Users\JGuy\OneDrive - Redwood Living, Inc\Documents\Lender Reporting\Automation\Output Test\"
    
    ' 创建正则表达式对象，匹配单元格末尾括号内的单词
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\((\w+)\)$"
    
    ' 创建字典，存储单词对应的工作簿完整路径
    Set WordToPath = CreateObject("Scripting.Dictionary")
    
    ' 遍历源工作簿所有工作表
    For Each SourceWorksheet In SourceWorkbook.Sheets
        Dim FoundWords As Boolean
        FoundWords = False
        
        Set SearchRange = SourceWorksheet.Range("A1:O3")
        For Each Cell In SearchRange
            If regex.Test(Cell.Value) Then
                Set match = regex.Execute(Cell.Value)(0)
                Dim TargetWord As String
                TargetWord = match.SubMatches(0)
                FoundWords = True
                
                If WordToPath.Exists(TargetWord) Then
                    ' 已存在对应工作簿，打开它并复制工作表
                    TargetPath = WordToPath(TargetWord)
                    Set TargetWorkbook = Workbooks.Open(TargetPath)
                    SourceWorksheet.Copy After:=TargetWorkbook.Sheets(TargetWorkbook.Sheets.Count)
                Else
                    ' 创建新工作簿，复制当前工作表
                    Set TargetWorkbook = Workbooks.Add
                    SourceWorksheet.Copy Before:=TargetWorkbook.Sheets(1)
                    
                    ' 删除默认空白工作表
                    Application.DisplayAlerts = False
                    TargetWorkbook.Sheets(2).Delete
                    Application.DisplayAlerts = True
                    
                    ' 生成保存路径并保存
                    TargetPath = BaseSavePath & "NewWorkbook_" & TargetWord & ".xlsx"
                    TargetWorkbook.SaveAs TargetPath
                    ' 将路径存入字典
                    WordToPath.Add TargetWord, TargetPath
                End If
                
                ' 保存并关闭目标工作簿，释放内存
                TargetWorkbook.Save
                TargetWorkbook.Close SaveChanges:=False
                Set TargetWorkbook = Nothing
                
                ' 找到匹配后退出当前单元格循环
                Exit For
            End If
        Next Cell
        
        ' 未找到匹配时提示
        If Not FoundWords Then
            MsgBox "在工作表" & SourceWorksheet.Name & "的指定区域未找到目标单词", vbInformation
        End If
    Next SourceWorksheet
    
    ' 清理对象
    Set SourceWorksheet = Nothing
    Set SourceWorkbook = Nothing
    Set SearchRange = Nothing
    Set WordToPath = Nothing
    Set regex = Nothing
    Set match = Nothing
End Sub

关键改动说明 #

• 字典存储逻辑调整：原代码字典存工作簿名称，改为存储工作簿的完整文件路径，方便后续需要追加工作表时直接定位打开
• 即时关闭工作簿：无论是新建工作簿还是打开已有工作簿完成工作表复制后，立即保存并关闭，避免大量工作簿同时占用内存
• 优化对象释放：每次操作完目标工作簿后，立即释放对象引用，进一步减少内存占用
• 路径统一管理：将保存路径单独提取为变量，便于后续修改维护

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