Копирование листа в новую книгу не копирует настройки VB-проекта

Question

Я сохраняю Sheet2 в новую книгу, копируя его, но при этом он не защищает мой код VBA, присутствующий в Sheet2 в новой книге. В оригинальной книге защищен проект VB.

Любые предложения о том, как сохранить только Sheet2 с настройками VB Project?

кода для разблокировки 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 защищен.

Простой способ добиться того, что вы хотите, это использовать Workbook.SaveCopyAs, а затем открыть эту копию и удалить ненужные листы.

Смотрите эту статью MSDN на Workbook.SaveCopyAs Method

В случае, если ссылка умирает, разместив скриншот этой страницы.

EDIT

Это будет делать то, что вы хотите. Однако это также скопирует и любые модули. Вам придется удалить их отдельно. Для этого вы можете увидеть Deleting A Module From A ProjectHERE

испытанный

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