将工作表复制到新工作簿不会复制VB项目设置

Question

我通过复制将Sheet2保存到新工作簿，但这样做会取消保护新工作簿中Sheet2中存在的VBA代码。原始工作簿受VB项目保护。

有关如何使用VB项目设置保存Sheet2的任何建议吗？

解锁VBA的代码：

Sub UnlockVBA(NewWbPath As String)
    Dim oWb As Object, xlAp As Object

    Set xlAp = CreateObject("Excel.Application")

    xlAp.Visible = True

    '~~> Open the workbook in a separate instance
    Set oWb = xlAp.Workbooks.Open(NewWbPath)

    '~~> Launch the VBA Project Password window
    '~~> I am assuming that it is protected. If not then
    '~~> put a check here.
    xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute

    '~~> Your passwword to open then VBA Project
    MyPassword = "pa$$w0rd"

    '~~> Get the handle of the "VBAProject Password" Window
    Ret = FindWindow(vbNullString, "VBAProject Password")

    If Ret <> 0 Then
        'MsgBox "VBAProject Password Window Found"

        '~~> Get the handle of the TextBox Window where we need to type the password
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)

        If ChildRet <> 0 Then
            'MsgBox "TextBox's Window Found"
            '~~> This is where we send the password to the Text Window
            SendMess MyPassword, ChildRet

            DoEvents

            '~~> Get the handle of the Button's "Window"
            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

            '~~> Check if we found it or not
            If ChildRet <> 0 Then
                'MsgBox "Button's Window Found"

                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff

                '~~> Loop through all child windows
                Do While ChildRet <> 0
                    '~~> Check if the caption has the word "OK"
                    If InStr(1, ButCap, "OK") Then
                        '~~> If this is the button we are looking for then exit
                        OpenRet = ChildRet
                        Exit Do
                    End If

                    '~~> Get the handle of the next child window
                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                    GetWindowText ChildRet, strBuff, Len(strBuff)
                    ButCap = strBuff
                Loop

                '~~> Check if we found it or not
                If OpenRet <> 0 Then
                    '~~> Click the OK Button
                    SendMessage ChildRet, BM_CLICK, 0, vbNullString
                Else
                    MsgBox "The Handle of OK Button was not found"
                End If
            Else
                 MsgBox "Button's Window Not Found"
            End If
        Else
            MsgBox "The Edit Box was not found"
        End If
    Else
        MsgBox "VBAProject Password Window was not Found"
    End If
End Sub

Answer 1

工作表或模块的VBA代码永远不会单独保护，但整个VBA项目都受到保护。

实现目标的简单方法是使用Workbook.SaveCopyAs，然后打开该副本并删除不需要的工作表。

请参阅Workbook.SaveCopyAs Method

上的这篇MSDN文章

如果该链接死亡，请发布该页面的屏幕截图。

修改

这将做你想要的。但是，这也将复制到任何模块。您必须单独删除它们。为此，您可能会看到Deleting A Module From A Project HERE

尝试和测试

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

Sub Sample()
    Dim NewWb As Workbook
    Dim ws As Worksheet
    Dim shName As String, NewWBName As String

    '~~> Name of the new workbook
    NewWBName = "Output.xlsm"
    '~~> Name of the sheet you want to copy across
    shName = "Sheet1"

    '~~> Create a copy in the users temp directory
    ThisWorkbook.SaveCopyAs TempPath & NewWBName

    '~~> Open the workbook
    Set NewWb = Workbooks.Open(TempPath & NewWBName)

    '~~> Delete unwanted sheets
    For Each ws In NewWb.Worksheets
        If ws.Name <> shName Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next

    '~~> Save the new file at desired location
    NewWb.SaveAs "C:\Output.xlsm", 52

    '~~> Delete temp file
    Kill TempPath & NewWBName
End Sub

Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function