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

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将总是 表示在代码执行的那一刻处于事件状态的工作簿。虽然有完全合法的时间和地点可以使用它，但它通常是 坏练习这样做，尤其是 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