如何保存含宏与公式的Excel新工作簿？VBA导出问题求助

需要实现以下Excel宏功能：

• 按筛选条件拆分并保存工作簿
• 隐藏指定工作表（如Sheet2）
• 锁定除Summary和Monthly_Budget中两个指定区域外的所有单元格

现有代码存在两个核心问题：

1. 新生成的工作簿无VBA宏代码，且公式仍引用原工作簿，无法独立运行
2. 仅复制筛选后的可见内容，丢失带筛选功能的表头

Sub ExportXLSM()
    Dim myWorksheets() As String
    Dim newWB As Workbook
    Dim CurrWB As Workbook
    Dim sht As Worksheet
    Dim userpath As String
    Dim sToday As String
    Dim s11 As Worksheet
    Dim MyPath As String
    Dim MyFileName As String
    Dim module As Object ' Late binding for VBComponent
    Dim summaryEditRanges As Range, budgetEditRanges As Range
    
    Set CurrWB = ThisWorkbook
    userpath = Environ("UserProfile")
    
    ' 获取日期命名参数
    Set s11 = CurrWB.Sheets("Monthly_Budget")
    sToday = s11.Range("A7").Value
    
    ' 定义需要复制的工作表集合
    myWorksheets = Split("Summary, Monthly_Budget, History_1, Copy2", ",")
    MyFileName = "KIG_BUDGET_2024_" & sToday & ".xlsm"
    
    ' 选择保存路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the location and click ok!"
        .AllowMultiSelect = False
        .InitialFileName = userpath & "\Desktop\"
        If .Show <> -1 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    
    ' 优化执行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 创建仅含一个空白工作表的新工作簿
    Set newWB = Workbooks.Add(xlWBATWorksheet)
    
    ' 复制目标工作表到新工作簿（保留筛选状态和公式引用）
    For Each sht In CurrWB.Sheets
        If Not IsError(Application.Match(Trim(sht.Name), myWorksheets, 0)) Then
            sht.Copy After:=newWB.Sheets(newWB.Sheets.Count)
        End If
    Next sht
    
    ' 删除默认空白工作表
    newWB.Sheets(1).Delete
    
    ' 复制VBA模块到新工作簿（需启用VBA项目对象模型访问权限）
    For Each module In CurrWB.VBProject.VBComponents
        If module.Type <> vbext_ct_Document Then
            Dim tempPath As String
            tempPath = Environ("Temp") & "\" & module.Name & ".bas"
            module.Export tempPath
            newWB.VBProject.VBComponents.Import tempPath
            Kill tempPath
        End If
    Next module
    
    ' 隐藏指定工作表（示例：Sheet2）
    On Error Resume Next
    Set sht = newWB.Sheets("Sheet2")
    If Not sht Is Nothing Then sht.Visible = xlSheetHidden
    On Error GoTo 0
    
    ' 配置Summary工作表的编辑权限
    Set sht = newWB.Sheets("Summary")
    sht.Unprotect
    sht.Cells.Locked = False
    ' 修改此处为实际允许编辑的区域
    Set summaryEditRanges = Union(sht.Range("A1:C10"), sht.Range("E1:F20"))
    summaryEditRanges.Locked = False
    sht.Protect Password:="YourSecurePassword", UserInterfaceOnly:=True, AllowFiltering:=True
    
    ' 配置Monthly_Budget工作表的编辑权限
    Set sht = newWB.Sheets("Monthly_Budget")
    sht.Unprotect
    sht.Cells.Locked = False
    ' 修改此处为实际允许编辑的区域
    Set budgetEditRanges = Union(sht.Range("A7:A15"), sht.Range("C2:C25"))
    budgetEditRanges.Locked = False
    sht.Protect Password:="YourSecurePassword", UserInterfaceOnly:=True, AllowFiltering:=True
    
    ' 自动调整列宽
    For Each sht In newWB.Sheets
        sht.UsedRange.Columns.AutoFit
    Next sht
    
    ' 保存并关闭新工作簿
    newWB.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    newWB.Close saveChanges:=True
    
    ' 恢复Excel默认设置
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

1. 保留筛选表头与状态：放弃原有的"复制可见区域"逻辑，改为直接复制整个工作表到新工作簿，完整保留筛选按钮和当前筛选状态。
2. 修复公式引用问题：复制工作表时，Excel会自动将公式中的跨工作簿引用转换为新工作簿的内部引用，确保公式独立可用。
3. 复制VBA宏代码：通过临时导出/导入VBA模块的方式，将原工作簿的宏代码迁移到新工作簿（需在Excel信任中心启用"信任对VBA项目对象模型的访问"）。
4. 隐藏指定工作表：添加容错逻辑，若目标工作表（如Sheet2）存在则隐藏，不存在则跳过。
5. 单元格权限配置：
   • 先解锁目标工作表的所有单元格
   • 仅保持指定编辑区域的解锁状态（允许用户编辑）
   • 启用工作表保护，同时允许筛选操作，UserInterfaceOnly:=True确保宏可直接修改工作表内容，无需反复解锁。

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