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

我将Sheet2复制到一个新的工作簿，但这样做不保护新工作簿中Sheet2中存在的VBA代码。 原始工作簿具有VB项目保护。

任何关于如何保存与VB项目设置Sheet2的build议？

代码解锁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方法的此MSDN文章

在链接死亡的情况下，张贴该页面的屏幕截图。

编辑

这将做你想要的。 但是，这也将复制到任何模块。 你将不得不分别删除它们。 为此，您可能会看到Deleting A Module From A Project

尝试和testing

 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