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

Mitesh Shah 发表于 Dev

米特什·沙（Mitesh Shah）

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

我面临两个问题：

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

2）运行button delete命令时，它将删除现有工作簿中的按钮，并在现有工作簿中插入一个新按钮。

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

复制文件，模块和按钮的代码如下所示。

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

斯科特·霍尔兹曼

您的问题源于您没有正确限定工作簿的事实。使用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