将宏复制到新工作簿答案

【问题标题】：Copying Macros to new workbooks将宏复制到新工作簿
【发布时间】：2022-01-22 22:58:53
【问题描述】：

请帮忙，我可以运行一个宏来从下拉列表中创建多个新工作簿并保存到指定位置。在原始文件中，有一些宏可以找到要放置在文件中的特定文件和工作表。有没有办法将宏复制到所有新工作表？我曾尝试在个人工作簿中使用宏，但它们似乎不起作用。谢谢

【问题讨论】：

可以将模块导出为 .bas 文件，嵌入在工作表中的宏可以导出为 .cls 文件。
嗨对于bas文件，您必须打开VB窗口并导入，这将非常耗时，有没有更快的方法？我尝试将保存的宏分配给保存的工作簿中的“按钮”，但它们似乎不起作用，因为它找不到文件夹和工作表，谢谢
不清楚您要做什么。你为什么不更详细地描述一个真实的场景？例如，我想将此工作簿中包含代码的工作表复制到新工作簿中。我也想复制这个工作簿的模块...
您好，我试图找到一种有效的方法将宏代码复制到所有新工作簿，我可以将新工作簿保存为启用宏的工作簿吗？
宏可以位于多个位置：ThisWorkbook 模块中，工作表模块中，例如Sheet1，在标准模块中，例如Module1 在类模块中，例如Class1。您要将哪个（哪些）复制到哪里？当您在未保存的工作簿中有宏时，它们已经可以工作了。如果要在保存后保留它们，则需要使用 .xlsm 或 .xlsb 扩展名来保存新工作簿。

【解决方案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

【讨论】：