尝试使用 VBA 代码创建新工作簿（in.xlsm 格式）

Question

我正在尝试使用现有工作簿的模板创建多个工作簿。 现有工作簿另存为 .xlsm。 当我尝试创建新工作簿时，出现错误。 但是在运行代码后，我有一条弹出消息询问我是否要“继续保存为无宏工作簿”

如果单击“否”，我会收到一条错误消息：错误：运行时错误“1004”。 VB 项目和 XLM 工作表不能保存在无宏工作簿中。

如果我单击是，我会收到一条错误消息：错误：此扩展名不能用于选定的文件类型。 我知道这是因为我已经为新工作簿提供了扩展名 as.xlsm，如果我希望将其保存为无宏工作簿，则需要将其更改为 .xlsx。

Sub vba_create_workbook()
    
    Workbooks.Add Template:="Folder Path\File Name.xlsm"
    ActiveWorkbook.SaveAs "Folder Path\File Name.xlsm"
    
    Workbooks.Add Template:="Folder Path\File Name.xlsm"
    ActiveWorkbook.SaveAs "Folder Path\File Name.xlsm"
  
End Sub

有什么方法可以将创建的新文件直接保存为启用宏的工作簿，即（.xlsm）？

Answer 1

从模板创建新工作簿

利用率

Sub RefNewTemplateTEST()
    
    Const SRC_FILE_PATH As String = "Folder Path\Source File Name.xlsm"
    Const DST_FILE_PATH As String = "Folder Path\Destination File Name.xlsm"
    
    Dim dwb As Workbook: Set dwb = RefNewTemplate(SRC_FILE_PATH, DST_FILE_PATH)
    
    If dwb Is Nothing Then Exit Sub
    
    ' Continue using dwb.
    
    MsgBox "Created '" & dwb.Name & "' from template.", vbInformation
    
End Sub

Function

Function RefNewTemplate( _
    TemplatePath As String, _
    DestinationPath As String) _
As Workbook
    Const PROC_TITLE As String = "Reference New Workbook From Template"
    
    If StrComp(TemplatePath, DestinationPath, vbTextCompare) = 0 Then
        MsgBox "The Template and Destination paths are the same.", _
            vbCritical, PROC_TITLE
        Exit Function
    End If
    
    Dim dwb As Workbook, ErrNum As Long
    Dim ErrDescription As String, MsgString As String
    
    On Error Resume Next
        Set dwb = Workbooks.Add(Template:=TemplatePath)
        ErrNum = Err.Number
        ErrDescription = Err.Description
    On Error GoTo 0
    
    If ErrNum <> 0 Then
        Select Case ErrDescription
            Case "Method 'Add' of object 'Workbooks' failed"
                MsgString = "The template is already open."
            Case "Sorry, Excel can't open two workbooks with " _
                    & "the same name at the same time."
                MsgString = "A file with the same name as the template is open."
            Case Else
        End Select
        MsgBox "Run-time error '" & ErrNum & "':" & vbLf & vbLf _
            & ErrDescription & IIf(Len(MsgString) > 0, vbLf & vbLf, "") _
            & MsgString, vbCritical, PROC_TITLE
        Exit Function
    End If
        
    Application.DisplayAlerts = False ' overwrite without confirmation
        On Error Resume Next
            dwb.SaveAs DestinationPath, xlOpenXMLWorkbookMacroEnabled
            ErrNum = Err.Number
            ErrDescription = Err.Description
        On Error GoTo 0
    Application.DisplayAlerts = True
     
    If ErrNum <> 0 Then
        dwb.Close SaveChanges:=False
        MsgBox "Run-time error '" & ErrNum & "':" & vbLf & vbLf _
            & ErrDescription, vbCritical
        Exit Function
    End If
  
    Set RefNewTemplate = dwb
  
End Function