將宏復制到新工作簿

Question

請幫忙，我可以運行一個宏來從下拉列表中創建多個新工作簿並保存到指定位置。 在原始文件中，有一些宏可以找到要放置在文件中的特定文件和工作表。 有沒有辦法將宏復制到所有新工作表？ 我曾嘗試在個人工作簿中使用宏，但它們似乎不起作用。 謝謝

Answer 1

打開 ThisWorkbook 的副本（模板）

• 這將在現有文件夾 ( FolderPath ) 中創建包含此代碼 ( ThisWorkbook ) 的工作簿的副本 ( SaveCopyAs )。 然后它將打開副本（ OldFilePath ）並將其保存為模板（ NewFilePath ）並關閉它。 然后它將刪除副本並打開模板（ LeftBaseName & "Template1" ）。

Option Explicit

Sub OpenMyTemplate()
    Const ProcName As String = "OpenMyTemplate"
    On Error GoTo ClearError
    
    Const FolderPath As String = "C:\Test" ' adjust this (has to exist)
    Const RightBaseName As String = "Template"
    Const NewExtension As String = ".xltm"
    
    Dim wbName As String: wbName = ThisWorkbook.Name
    
    Dim DotPosition As Long: DotPosition = InStrRev(wbName, ".")
    Dim LeftBaseName As String: LeftBaseName = Left(wbName, DotPosition - 1)
    
    Dim OldExtension As String
    OldExtension = Right(wbName, Len(wbName) - DotPosition)
    
    Dim BaseName As String: BaseName = LeftBaseName & RightBaseName
    
    Dim BaseNamePath As String
    BaseNamePath = FolderPath & Application.PathSeparator & BaseName
    
    Dim OldFilePath As String: OldFilePath = BaseNamePath & OldExtension
    ' Save a copy of the workbook containing this code
    ThisWorkbook.SaveCopyAs OldFilePath
    
    Dim NewFilePath As String: NewFilePath = BaseNamePath & NewExtension
    
    Application.ScreenUpdating = False
    
    With Workbooks.Open(OldFilePath) ' open the copy
        Application.DisplayAlerts = False ' overwrite without confirmation
        .SaveAs NewFilePath, xlOpenXMLTemplateMacroEnabled ' save as template
        Application.DisplayAlerts = True
        .Close SaveChanges:=False
    End With
    
    Kill OldFilePath ' delete the copy
    
    Workbooks.Open NewFilePath ' open the template

    Application.ScreenUpdating = True

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub