如何不关闭当前文件保存ThisWorkbook的无宏xlsx副本？

嘿，这个问题我之前踩过好几次坑！SaveCopyAs确实鸡肋，完全不支持改格式；SaveAs又会“偷换”当前工作簿，把原文件给换掉，太闹心了。而且还要保留ContentTypeProperties，普通的复制工作表还真不够。

给你一个稳定靠谱的方案，核心思路是创建新工作簿复制原内容+同步ContentTypeProperties，完全不影响原工作簿的状态：

Sub SaveAsNonMacroEnabledCopy()
    Dim newWB As Workbook
    Dim prop As DocumentProperty
    Dim originalPath As String
    
    ' 记录原工作簿路径，避免后续操作干扰
    originalPath = ThisWorkbook.FullName
    
    ' 创建新工作簿，复制原工作簿的所有工作表
    Set newWB = Workbooks.Add(xlWBATWorksheet)
    ThisWorkbook.Sheets.Copy After:=newWB.Sheets(newWB.Sheets.Count)
    ' 删除新工作簿默认的空白工作表
    Application.DisplayAlerts = False
    newWB.Sheets(1).Delete
    Application.DisplayAlerts = True
    
    ' 同步原工作簿的ContentTypeProperties到新工作簿
    For Each prop In ThisWorkbook.ContentTypeProperties
        On Error Resume Next ' 跳过可能存在的同名属性
        newWB.ContentTypeProperties.Add _
            Name:=prop.Name, _
            Value:=prop.Value, _
            ReadOnly:=prop.ReadOnly
        On Error GoTo 0
    Next prop
    
    ' 保存新工作簿为xlsx格式（无宏）
    ' 这里可以自定义保存路径和文件名，比如在原路径后加"_无宏副本"
    Dim savePath As String
    savePath = Left(originalPath, InStrRev(originalPath, ".")) & "xlsx"
    savePath = Replace(savePath, ".xlsb", "_无宏副本.xlsx") ' 根据原格式调整
    
    newWB.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    newWB.Close SaveChanges:=False ' 关闭新工作簿，原工作簿保持打开状态
    
    MsgBox "无宏副本已保存至：" & savePath, vbInformation
End Sub

为什么这个方案靠谱？ #

• 完全不触动原工作簿：原文件始终保持打开状态，你可以继续操作，不会被SaveAs切换或者关闭
• 完整保留ContentTypeProperties：通过循环逐一复制原属性，确保元数据不丢失
• 稳定无意外：没有复杂的文件重新打开操作，也不会触发不必要的弹窗

另外要注意几个细节：

• 如果原工作簿有隐藏工作表，这个代码也会一并复制，不需要额外处理
• Application.DisplayAlerts = False是为了避免删除默认空白表时的确认弹窗，用完记得改回True
• 保存路径可以根据你的需求自定义，比如指定到某个文件夹，或者让用户选择路径

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