这段代码的目的是在每个工作表的顶部查找特定的单词，并根据找到的单词创建一个工作簿。然后，代码将每个同名的工作表添加到以这种方式创建的新工作簿中。我的问题是，大约175个或更多的工作簿需要以这种方式创建，代码正在这样做，但它保持太多的工作簿打开，这导致我的电脑运行RAM造成内存问题.我需要每一个新的工作簿被关闭后，必要的工作表被添加形式的原始工作簿.我知道必须有一种方法来让工作簿保存和关闭后，必要的工作表已被复制了，但我似乎不能让它工作.
下面是我使用的代码：

Sub Save()

 Dim SourceWorkbook As Workbook`
 Dim SourceWorksheet As Worksheet
 Dim SearchRange As Range
 Dim Cell As Range
 Dim NewWorkbook As Workbook
 Dim NewWorksheet As Worksheet
 Dim FoundWords As Boolean
 Dim regex As Object
 Dim match As Object
 Dim SheetNames As Object
 Dim SheetName As String

   ' Set the source workbook and worksheet
   Set SourceWorkbook = ThisWorkbook

 ' Create a regular expression object
 Set regex = CreateObject("VBScript.RegExp")
 regex.Pattern = "\((\w+)\)$" ' Pattern to match any word enclosed in parentheses at the end of        a cell

' Create a dictionary to hold unique sheet names
Set SheetNames = CreateObject("Scripting.Dictionary")

' Loop through all sheets in the workbook
For Each SourceWorksheet In SourceWorkbook.Sheets
    ' Reset flag for each sheet
    FoundWords = False
    
    ' Define the search range in the source worksheet
    Set SearchRange = SourceWorksheet.Range("A1:O3")
    
    ' Loop through each cell in the search range
    For Each Cell In SearchRange
        ' Check if the cell contains the desired word enclosed in parentheses at the end
        If regex.Test(Cell.Value) Then
            ' Get the match object
            Set match = regex.Execute(Cell.Value)(0)
            
            FoundWords = True ' Set flag to indicate that words were found
            
            ' Check if a new workbook has been created for this set of found words
            If SheetNames.exists(match.SubMatches(0)) Then
                ' Copy the entire source worksheet to a new worksheet in the existing new workbook
                SheetName = SheetNames(match.SubMatches(0))
                SourceWorksheet.Copy After:=Workbooks(SheetName).Sheets(Workbooks(SheetName).Sheets.count)
            Else
                ' Create a new workbook
                Set NewWorkbook = Workbooks.Add
                Set NewWorksheet = NewWorkbook.Sheets(1)
                
                ' Copy the entire source worksheet to the new worksheet in the new workbook
                SourceWorksheet.Copy Before:=NewWorksheet
                
                ' Delete the default blank sheet in the new workbook
                Application.DisplayAlerts = False ' Disable alerts to prevent prompt
                NewWorkbook.Sheets(2).Delete
                Application.DisplayAlerts = True ' Re-enable alerts
                
                ' Save the new workbook with a name based on the words found
                NewWorkbookName = "NewWorkbook_" & match.SubMatches(0) & ".xlsx" ' Update with your desired naming convention
                NewWorkbook.SaveAs "C:\Users\JGuy\OneDrive - Redwood Living, Inc\Documents\Lender Reporting\Automation\Output Test\" & NewWorkbookName
                SheetNames.Add match.SubMatches(0), NewWorkbook.Name ' Add the sheet name to the dictionary
                
            End If
            
       
            
            ' Exit the loop after first set of found words
            Exit For
        End If
    Next Cell
    
    ' Display a message box if no words were found in the sheet
    If Not FoundWords Then
        MsgBox "No words found in the specified range in " & SourceWorksheet.Name, vbInformation
    End If
    
    ' Reset new worksheet reference
    Set NewWorksheet = Nothing
Next SourceWorksheet

' Close all new workbooks
For Each WB In Workbooks
If Left(WB.Name, 11) = "NewWorkbook" Then ' Check if the workbook name starts with "NewWorkbook"
    WB.Close False ' Close the workbook without saving changes
End If
Next WB

' Clean up objects
Set SourceWorksheet = Nothing
Set SourceWorkbook = Nothing
Set SearchRange = Nothing
Set NewWorksheet = Nothing
Set NewWorkbook = Nothing
Set SheetNames = Nothing
Set regex = Nothing

End Sub