将工作表、代码和按钮复制到新文件

Question

我已经创建了一些代码，我的要求之一是复制某些工作表、模块和按钮以将这些模块引用到新工作簿。

我面临两个问题：

1) 在尝试各种操作时，我能够复制工作表和模块。但是，问题是当我将模块按钮复制到新工作表时，它仍然引用原始文件而不是已创建的新文件。

2) 当按钮删除命令运行时，它会从现有工作簿中删除按钮并在现有工作簿中插入一个新按钮。

我可以理解，在某个地方我无法返回到原始文件，但无法弄清楚在哪里以及如何转到新文件来执行代码。

复制文件、模块和按钮的代码如下。

Sub Workbook_Open()

Dim filename4 As String:
strFilename4 = "\Work Data " & Format(Now(), "ddmmyy hhmmss")
filename4 = ActiveWorkbook.Path & strFilename4 & ".xlsm"

Dim nm As Name
Dim ws As Worksheet
    Sheets(Array("Sheet1", "Sheet2")).Copy
        For Each nm In ActiveWorkbook.Names
          If InStr(1, nm.RefersTo, "#REF!") > 0 Then
            Debug.Print nm.Name & ": deleted"
            nm.Delete
          End If
        Next nm

ActiveWorkbook.SaveAs filename:=filename4, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close

Const MODULE_NAME    As String = "DataValidityCheck"         ' Name of the module to transfer
Const TEMPFILE       As String = "c:\DataValidityCheck.bas" ' temp textfile
Dim WBK As Workbook
Set WBK = Workbooks.Open(filename4)

'Copy Module to New Workbook
   On Error Resume Next
   Set WBK = Workbooks(filename4)
   ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
   WBK.VBProject.VBComponents.Import TEMPFILE
   Kill TEMPFILE

'Delete every shape in the Shapes collection
    Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        myshape.Delete
    Next myshape

    ThisWorkbook.ActiveSheet.Buttons.Add(2538, 4.5, 71.25, 14.25).Select

    With btn
        .Caption = "Validate Data" 'change the name of the button accordingly
        .OnAction = "msg"
    End With
    Selection.OnAction = "Workbook_Open"
 ActiveWorkbook.Close SaveChanges:=True

End If
Application.CutCopyMode = False
End Sub

Answer 1

您的问题源于您没有正确限定工作簿。使用 ThisWorkbook 将总是表示工作簿运行代码。使用 ActiveWorkbook 将 always 表示在代码执行的那一刻处于活动状态的工作簿。虽然有完全合法的时间和地点使用它，但这样做通常是 不好的 做法，尤其是 ActiveWorkbook（和 ActiveSheet 就此而言）。

我用完整的注释重构了您的代码来说明这一点，并清理了其中一些其他与语法相关的内容。

Sub Workbook_Open()

Const MODULE_NAME    As String = "DataValidityCheck"         ' Name of the module to transfer
Const TEMPFILE       As String = "c:\DataValidityCheck.bas" ' temp textfile

'qualify main workbook
Dim wbkMain As Workbook
Set wbkMain = ThisWorkbook
'export desired module
With wbkMain

    .VBProject.VBComponents(MODULE_NAME).Export TEMPFILE

    'copy out sheets
    .Sheets(Array("Sheet1", "Sheet2")).Copy

End With

'qualify new workbook
Dim WBK As Workbook
Set WBK = ActiveWorkbook 'this is one of only a few times its required to use 'ActiveWorkbook'

'work directly with new workbook
With WBK

    'Copy Module to New Workbook
    .VBProject.VBComponents.Import TEMPFILE
    Kill TEMPFILE

    'delete bad names
    Dim nm As Name
    For Each nm In .Names
        If InStr(1, nm.RefersTo, "#REF!") Then nm.Delete
    Next

    'Delete every shape in the Shapes collection
    With .Sheets(1) 'change to 2 if you need sheet 2

        Dim myshape As Shape
        For Each myshape In .Shapes 'change to 2 if you need sheet 2
            myshape.Delete
        Next myshape

        .Buttons.Add(2538, 4.5, 71.25, 14.25).Select

        With Selection 'should really set this to a variable as well, but I didn't feel like looking the right syntax
            .Caption = "Validate Data" 'change the name of the button accordingly
            .OnAction = "msg" 'Workbook_Open if need be
        End With

    End With

    'finally save the new workbook
    Dim filename4 As String, strFilename4 As String
    strFilename4 = "\Work Data " & Format(Now(), "ddmmyy hhmmss")
    filename4 = ActiveWorkbook.Path & strFilename4 & ".xlsm"

    .SaveAs Filename:=filename4, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

    .Close True 'don't need since you just saved, but why not

End With

Application.CutCopyMode = False

End Sub

将工作表、代码和按钮复制到新文件

copy worksheet, code and button to a new file

excel

vba

module

button