从模板创建新工作簿

利用率

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 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