☰

如何将 VBA 代码从一个电子表格复制/粘贴或导入/导出到另一个电子表格？

tag-icon • tag-icon microsoft-excel vba
如何将 VBA 代码从一个电子表格复制/粘贴或导入/导出到另一个电子表格？

我在 Excel 电子表格 (Excel 2016) 中编写了一些 VBA 代码。我之前在示例电子表格中工作，现在我想轻松地将我的 VBA 代码移植到真正的电子表格中。复制/粘贴命令按钮不会保留任何代码。我不想做一大堆手动复制粘贴。

我知道您可以导出单个模块/类，但我还没有找到一次性导出所有内容的方法。我需要为此自定义 vba 代码吗？某种附加组件？或者 Excel 中是否有我错过的内置流程？

我在工作表上有一些用户表单、模块和一些按钮。我可以手动完成，但如果以后必须再次执行，我担心会犯错误。

自动建议问题，尽管标题与我所看到的完全相反，但不适用。我尝试将工作表复制到另一个电子表格，但 VBA 代码没有复制过来。但工作表和工作表上的按钮却复制过来了。

元

当我问这个问题时，我得到了一个自动回复“这个问题似乎很主观，很可能会被关闭”。我向你保证，这不是主观，尽管这可能是一个非常 n00b 级别的问题。

在此处输入图片描述

答案1

这是我之前编写的一个程序，用于在 VBA 损坏的情况下将尽可能多的 VBA 移动到另一个工作簿 - 您可以根据需要随意调整它。

重要的提示：为了实现此功能，您需要在安全设置中启用对 VBProject 的访问权限。您还需要关闭要复制的工作簿。

更多重要提示：此代码将创建一个临时目录，并在完成后将其删除 - 请检查代码中的所有路径和名称，以确保这不是您系统上现有的文件夹。对于因未正确检查而运行此代码而导致系统上的任何文件/数据丢失，我概不负责。

Sub CopyBrokenWorkbook() 

     '// This sub will create a duplicate workbook with the prefix "EXP_"
     '// and import all userforms & code modules from old workbook.
     '
     '// This sub requires access to the VBA Project Object Model, this option can
     '// be found in the trust center settings under "Macro Settings".


    Dim oldWB As Workbook, newWB As Workbook 
    Dim VBc As Variant 
    Dim exportFolder As String, VBcExt As String, Bill As String, _ 
    newWBPath As String, testFile As String, wbPass As String 
    Dim i As Integer 


     '//Set old workbook
    testFile = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*") 
    If LCase(testFile) = "false" Then Exit Sub 


    If MsgBox("Is this workbook password protected?", vbYesNo) = vbYes Then _ 
    wbPass = InputBox("Please enter workbook password:") 


    On Error Resume Next 
    Set oldWB = Workbooks.Open(testFile, Password:=wbPass) 
    If Err.Number = 1004 Then 
        MsgBox "Incorrect workbook password, this macro will now stop.", vbExclamation + vbOKOnly, "Error" 
        Err.Clear 
        Set oldWB = Nothing 
        Exit Sub 
    End If 
    On Error Goto 0 


    If oldWB.Name = ThisWorkbook.Name Then 
        MsgBox "Cannot run sub on this workbook!", vbCritical + vbOKOnly, "Error" 
        Exit Sub 
    End If 


     '//Check VBA protection
    On Error Resume Next 
    If oldWB.VBProject.Protection <> 0 Then 
        If Err.Number = 1004 Then 
            Err.Clear 
            MsgBox "VBA Project Object Model is protected in " & oldWB.Name & vbCrLf _ 
            & vbCrLf & "Please remove this protection in Trust Centre to continue.", _ 
            vbExclamation + vbOKOnly, "Error" 

            oldWB.Close 
            Set oldWB = Nothing 
            Set newWB = Nothing 
            Exit Sub 
        Else 
            MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error" 
            oldWB.Close 
            Set oldWB = Nothing 
            Set newWB = Nothing 
            Err.Clear 
            Exit Sub 
        End If 

    End If 
    On Error Goto 0 


    Set newWB = Workbooks.Add 


     '//path to export folder
    exportFolder = oldWB.Path & "\ExportTest" 


     '//if export folder exists, remove all files, otherwise creaate the folder
    If CreateObject("Scripting.FileSystemObject").FolderExists(exportFolder) = True Then 
        On Error Resume Next 
        Kill exportFolder & "\*.*" 
        Err.Clear 
        On Error Goto 0 
    Else 
        MkDir exportFolder 
    End If 


     '//export all modules/class modules/userforms to folder
    For Each VBc In oldWB.VBProject.VBComponents 
        Select Case VBc.Type 
        Case 1 
            VBcExt = ".bas" 
        Case 2 
            VBcExt = ".cls" 
        Case 3 
            VBcExt = ".frm" 
        Case 100 
            VBcExt = "SKIP" 
        End Select 
        If Not VBcExt = "SKIP" Then VBc.Export exportFolder & "\" & VBc.Name & VBcExt 
    Next VBc 


     '//duplicate sheet count in new workbook
    Application.DisplayAlerts = False 
    Select Case oldWB.Sheets.Count 
    Case Is < 3 
        While newWB.Sheets.Count <> oldWB.Sheets.Count 
            newWB.Sheets(newWB.Sheets.Count).Delete 
        Wend 
    Case Is > 3 
        While newWB.Sheets.Count <> oldWB.Sheets.Count 
            newWB.Sheets.Add after:=newWB.Sheets.Count 
        Wend 
    End Select 
    Application.DisplayAlerts = True 


     '//duplicate sheet names in new workbook
    For i = 1 To Sheets.Count 
        newWB.Sheets(i).Name = oldWB.Sheets(i).Name 
    Next i 


     '//save new workbook with old workbook's attributes and "EXP_" prefix
    With oldWB 


        newWBPath = exportFolder & "\EXP_" & .Name 


        newWB.SaveAs newWBPath, .FileFormat 
    End With 


     '//import modules/class modules/userforms to new workbook
    For Each VBc In CreateObject("Scripting.FileSystemObject").GetFolder(exportFolder).Files 
        Select Case LCase(Right(VBc.Name, 4)) 
        Case ".bas", ".frm", ".cls" 
            newWB.VBProject.VBComponents.Import exportFolder & "\" & VBc.Name 
        End Select 
    Next VBc 


     '//save new workbook
    newWB.Save 


     '//get pathname of old workbook for later
    Bill = oldWB.Path & "\" & oldWB.Name 


     '//close workbooks
    oldWB.Close False 
    newWB.Close False 


     '//release from memory
    Set oldWB = Nothing 
    Set newWB = Nothing 


     '//create an excuse to reference a cool film whilst removing old workbook
    '// Kill Bill <~~ ONLY UNCOMMENT THIS LINE IF YOU WANT TO DELETE ORIGINAL WORKBOOK! 


     '//move new workbook to old workbook directory
    CreateObject("Scripting.FileSystemObject").GetFile(newWBPath).Move _ 
    Mid(Bill, 1, InStrRev(Bill, "\")) 

    On Error Resume Next 
    Kill exportFolder & "\*.*" 
    On Error Goto 0 


    RmDir exportFolder 


    MsgBox "Transfer complete, please re-apply any password protection to your new workbook.", _ 
    vbInformation, "Done" 

End Sub

相关内容