将所有 VBA 代码从工作簿复制到另一个

Question

我搜索了很多，发现了很多 VBA 代码模块的 VBA 代码，但我需要的有点不同。 我有一个大型项目，在标准模块、工作表模块、ThisWorkbook 模块中有很多 VBA 代码。 所有这些都有 VBA 代码，还有另一个工作簿说（“New.xlsm”），我需要将所有这些 VBA 代码复制到它。 但在导出这些 VBA 代码之前，我需要从任何模块的任何代码中清除“New.xlsm”，或者删除任何现有模块并清除所有内容..然后将 vba 代码复制到“New.xlsm”。

我有这段代码可以导出所有 VBE 组件，但这可能只是一个步骤。

Sub Export_All_VBE_Components()
'References: Microsoft Visual Basic for Applications Extensibility 5.3
'---------------------------------------------------------------------
    Dim vbComp          As VBIDE.VBComponent
    Dim destDir         As String
    Dim fName           As String
    Dim ext             As String

    If ActiveWorkbook.Path = "" Then MsgBox "You Must First Save This Workbook Somewhere So That It Has A Path.", , "Error": Exit Sub
    destDir = ActiveWorkbook.Path & "\" & ActiveWorkbook.name & " Modules"
    If Dir(destDir, vbDirectory) = vbNullString Then MkDir destDir

    For Each vbComp In ActiveWorkbook.VBProject.VBComponents
        If vbComp.CodeModule.CountOfLines > 0 Then
            Select Case vbComp.Type
                Case vbext_ct_ClassModule: ext = ".cls"
                Case vbext_ct_Document: ext = ".cls"
                Case vbext_ct_StdModule: ext = ".bas"
                Case vbext_ct_MSForm: ext = ".frm"
                Case Else: ext = vbNullString
            End Select

            If ext <> vbNullString Then
                fName = destDir & "\" & vbComp.name & ext
                If Dir(fName, vbNormal) <> vbNullString Then Kill (fName)
                vbComp.Export (fName)
            End If
        End If
    Next vbComp
End Sub

我已经解决了从“original.xlm”中删除所有现有代码的第一步

Sub Test_RemoveAllMacros()
    Application.ScreenUpdating = False
        RemoveAllMacros Application.Workbooks("Original.xlsm")
    Application.ScreenUpdating = True
End Sub

Sub RemoveAllMacros(wbk As Workbook)
    Dim vbCode As Object, vbComp As Object, vbProj As Object
    Set vbProj = wbk.VBProject
    With vbProj
        For Each vbComp In .VBComponents
            Select Case vbComp.Type
                Case 1, 2, 3
                    vbProj.VBComponents.Remove vbComp
                Case 100
                    Set vbCode = vbComp.CodeModule
                    vbCode.DeleteLines 1, vbCode.CountOfLines
            End Select
        Next vbComp
    End With
End Sub

我现在需要的是将所有宏从“New.xlm”复制到“Original.xlsm”

我找到了这段代码，但这需要命名我需要复制的每个模块。 我不需要指定任何模块名称，因为我有大约 30 个模块和工作表模块......还有 ThisWorkbook 模块

Sub Copy_module()
    Dim varModule, wbkSource As Workbook, wbkTarget As Workbook, strModule As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
        Set wbkSource = ThisWorkbook
            Set wbkTarget = Application.Workbooks("Original.xlsm")
            With wbkTarget.VBProject.VBComponents
                For Each varModule In Array("Module1", "Module2")
                    strModule = ThisWorkbook.Path & "\" & varModule & ".bas"
                    wbkSource.VBProject.VBComponents(varModule).Export Filename:=strModule
                    On Error Resume Next
                        .Remove VBComponent:=.Item(varModule)
                    On Error GoTo 0
                    .Import Filename:=ThisWorkbook.Path & "\" & varModule & ".bas"
                    Kill strModule
                Next varModule
            End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

*** 要复制工作表模块，我发现了这个

Sub CopyWorksheetsModules()
    Dim src, dest, wb As Workbook, ws As Worksheet
    On Error Resume Next
        For Each ws In ThisWorkbook.Worksheets
            Set src = ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
            Set wb = Workbooks("Original.xlsm")
            Set dest = wb.VBProject.VBComponents(ws.CodeName).CodeModule
            dest.DeleteLines 1, dest.CountOfLines
            dest.AddFromString src.Lines(1, src.CountOfLines)
        Next ws
    On Error GoTo 0
End Sub

Answer 1

我没有测试过这段代码，但这是我发现的：

要将模块从一个工作簿复制到另一个[credit] ：

Sub CopyModule(SourceWB As Workbook, strModuleName As String, _
    TargetWB As Workbook)
' 
' example: 
' CopyModule Workbooks("Book1.xls"), "Module1", _
    Workbooks("Book2.xls")
Dim strFolder As String, strTempFile As String
    strFolder = SourceWB.Path
    If Len(strFolder) = 0 Then strFolder = CurDir
    strFolder = strFolder & "\"
    strTempFile = strFolder & "~tmpexport.bas"
    On Error Resume Next
    SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
    TargetWB.VBProject.VBComponents.Import strTempFile
    Kill strTempFile
    On Error GoTo 0
End Sub

要从工作簿中删除所有代码[credit] ：

Sub DeleteAllCode() 

     'Trust Access To Visual Basics Project must be enabled.
     'From Excel: Tools | Macro | Security | Trusted Sources

    Dim x               As Integer 

    On Error Resume Next 
    With Workbooks("Wb").VBProject 
        For x = .VBComponents.Count To 1 Step -1 
            .VBComponents.Remove .VBComponents(x) 
        Next x 
        For x = .VBComponents.Count To 1 Step -1 
            .VBComponents(x).CodeModule.DeleteLines _ 
            1, .VBComponents(x).CodeModule.CountOfLines 
        Next x 
    End With 
    On Error GoTo 0 

End Sub 

希望有帮助。

Answer 2

这是我用来导入/导出模块的代码。 导出模块将删除保存它们的文件夹中的所有当前文件。 并且导入模块将在导入之前删除所有模块。 请注意：

ElseIf Not VBComp.Name Like "*Modulos*" Then
     VBProj.VBComponents.Remove VBComp
End If

是为了避免删除处理导入/导出的模块。 它们被称为ImportarModulos和ExportarModulos ，因此请使用关键字来识别它们并避免删除和导入它们（因为它可能会给您带来问题。）

导出模块：

Option Explicit
Public Sub ExportModules()
    Dim bExport As Boolean
    Dim wkbSource As Excel.Workbook
    Dim szSourceWorkbook As String
    Dim szExportPath As String
    Dim szFileName As String
    Dim cmpComponent As VBIDE.VBComponent

    ''' The code modules will be exported in a folder named.
    ''' VBAProjectFiles in the Documents folder.
    ''' The code below create this folder if it not exist
    ''' or delete all files in the folder if it exist.
    If FolderWithVBAProjectFiles = "Error" Then
        MsgBox "Export Folder not exist"
        Exit Sub
    End If

    On Error Resume Next
        Kill FolderWithVBAProjectFiles & "\*.*"
    On Error GoTo 0

    ''' NOTE: This workbook must be open in Excel.
    szSourceWorkbook = ActiveWorkbook.Name
    Set wkbSource = Application.Workbooks(szSourceWorkbook)

    If wkbSource.VBProject.Protection = 1 Then
    MsgBox "The VBA in this workbook is protected," & _
        "not possible to export the code"
    Exit Sub
    End If

    szExportPath = FolderWithVBAProjectFiles & "\"

    For Each cmpComponent In wkbSource.VBProject.VBComponents

        bExport = True
        szFileName = cmpComponent.Name

        ''' Concatenate the correct filename for export.
        Select Case cmpComponent.Type
            Case vbext_ct_ClassModule
                szFileName = szFileName & ".cls"
            Case vbext_ct_MSForm
                szFileName = szFileName & ".frm"
            Case vbext_ct_StdModule
                szFileName = szFileName & ".bas"
            Case vbext_ct_Document
                ''' This is a worksheet or workbook object.
                ''' Don't try to export.
                bExport = False
        End Select
        If bExport Then
            ''' Export the component to a text file.
            cmpComponent.Export szExportPath & szFileName
        ''' remove it from the project if you want
        '''wkbSource.VBProject.VBComponents.Remove cmpComponent
        End If
    Next cmpComponent

    Dim wb As Workbook, ws As Worksheet, LastRow As Long
    Set wb = Workbooks.Open("Z:\Planificacion-WFM\Planificacion Telefonica\Código\Log.xlsx")
    Set ws = wb.Sheets(1)
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    ws.Cells(LastRow, 1) = Application.UserName
    ws.Cells(LastRow, 2) = Format(Now(), "hh:mm:ss")
    ws.Cells(LastRow, 3) = Format(Now(), "dd/mm/yyyy")
    wb.Close Savechanges:=True


    MsgBox "Export is ready"
End Sub
Function FolderWithVBAProjectFiles() As String
    Dim WshShell As Object
    Dim FSO As Object
    Dim SpecialPath As String

    Set WshShell = CreateObject("WScript.Shell")
    Set FSO = CreateObject("scripting.filesystemobject")

    SpecialPath = "Z:\Planificacion-WFM\Planificacion Telefonica\Código"

    If Right(SpecialPath, 1) <> "\" Then
        SpecialPath = SpecialPath & "\"
    End If

    If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
        On Error Resume Next
        MkDir SpecialPath & "VBAProjectFiles"
        On Error GoTo 0
    End If

    If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
        FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
    Else
        FolderWithVBAProjectFiles = "Error"
    End If

End Function

导入模块：

Option Explicit
Public Sub ImportModules()
    Dim wkbTarget As Excel.Workbook
    Dim objFSO As Scripting.FileSystemObject
    Dim objFile As Scripting.File
    Dim szTargetWorkbook As String
    Dim szImportPath As String
    Dim szFileName As String
    Dim cmpComponents As VBIDE.VBComponents
'
'    If ActiveWorkbook.Name = ThisWorkbook.Name Then
'        MsgBox "Select another destination workbook" & _
'        "Not possible to import in this workbook "
'        Exit Sub
'    End If

    'Get the path to the folder with modules
    If FolderWithVBAProjectFiles = "Error" Then
        MsgBox "Import Folder not exist"
        Exit Sub
    End If

    ''' NOTE: This workbook must be open in Excel.
    szTargetWorkbook = ActiveWorkbook.Name
    Set wkbTarget = Application.Workbooks(szTargetWorkbook)

    If wkbTarget.VBProject.Protection = 1 Then
    MsgBox "The VBA in this workbook is protected," & _
        "not possible to Import the code"
    Exit Sub
    End If

    ''' NOTE: Path where the code modules are located.
    szImportPath = FolderWithVBAProjectFiles & "\"

    Set objFSO = New Scripting.FileSystemObject
    If objFSO.GetFolder(szImportPath).Files.Count = 0 Then
       MsgBox "There are no files to import"
       Exit Sub
    End If

    'Delete all modules/Userforms from the ActiveWorkbook
    Call DeleteVBAModulesAndUserForms

    Set cmpComponents = wkbTarget.VBProject.VBComponents

    ''' Import all the code modules in the specified path
    ''' to the ActiveWorkbook.
    For Each objFile In objFSO.GetFolder(szImportPath).Files
        If objFile.Name Like "*Modulos*" Then GoTo Siguiente
        If (objFSO.GetExtensionName(objFile.Name) = "cls") Or _
            (objFSO.GetExtensionName(objFile.Name) = "frm") Or _
            (objFSO.GetExtensionName(objFile.Name) = "bas") Then
            cmpComponents.Import objFile.Path
        End If
Siguiente:
    Next objFile

    MsgBox "Módulos actualizados"
End Sub

Function DeleteVBAModulesAndUserForms()
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent

        Set VBProj = ActiveWorkbook.VBProject

        For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                'Thisworkbook or worksheet module
                'We do nothing
            ElseIf Not VBComp.Name Like "*Modulos*" Then
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
End Function

Answer 3

非常感谢 Damian 在这个主题上的巨大贡献。 我非常感谢他的帮助。 这是我从不同资源收集的最终代码，代码将分两步执行。 代码将放在“New.xlsm”中，其中包含我需要复制的所有模块（源工作簿），它将所有模块（所有类型）复制到“original.xlsm”（目标工作簿）

'References: Microsoft Visual Basic for Applications Extensibility 5.3
'---------------------------------------------------------------------
Public destDir As String
Const destWorkbook As String = "Original.xlsm"

Sub P1_Export_All_VBE_Components()
    Dim vbComp As VBIDE.VBComponent, fName As String, ext As String
    If ThisWorkbook.Path = "" Then MsgBox "You Must First Save This Workbook Somewhere So That It Has A Path.", , "Error": Exit Sub
    destDir = ThisWorkbook.Path & "\" & ThisWorkbook.Name & " Modules"
    If Dir(destDir, vbDirectory) = vbNullString Then MkDir destDir
    For Each vbComp In ThisWorkbook.VBProject.VBComponents
        If vbComp.CodeModule.CountOfLines > 0 Then
            Select Case vbComp.Type
                Case vbext_ct_ClassModule: ext = ".cls"
                Case vbext_ct_StdModule: ext = ".bas"
                Case vbext_ct_MSForm: ext = ".frm"
                Case Else: ext = vbNullString
            End Select
            If ext <> vbNullString Then
                fName = destDir & "\" & vbComp.Name & ext
                If Dir(fName, vbNormal) <> vbNullString Then Kill (fName)
                vbComp.Export (fName)
            End If
        End If
    Next vbComp
End Sub

Sub P2_Remove_Macros_Copy_All_Modules()
    Dim src, dest, wbTarget As Workbook, ws As Worksheet, fso As Object, oFile As Object, sCode As String
    Application.ScreenUpdating = False
        Set wbTarget = Application.Workbooks(destWorkbook)
        If wbTarget.VBProject.Protection = 1 Then MsgBox "The VBA In Target Workbook Is Protected", vbExclamation: Exit Sub
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.GetFolder(destDir).Files.Count = 0 Then MsgBox "There Are No Files To Export", vbExclamation: Exit Sub

        RemoveAllMacros wbTarget

        For Each oFile In fso.GetFolder(destDir).Files
            If fso.GetExtensionName(oFile.Name) = "cls" Or fso.GetExtensionName(oFile.Name) = "bas" Or fso.GetExtensionName(oFile.Name) = "frm" Then
                wbTarget.VBProject.VBComponents.Import oFile.Path
            End If
        Next oFile

        On Error Resume Next
            For Each ws In ThisWorkbook.Worksheets
                Set src = ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
                Set dest = wbTarget.VBProject.VBComponents(ws.CodeName).CodeModule
                dest.AddFromString src.Lines(1, src.CountOfLines)
            Next ws
        On Error GoTo 0

        With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
            sCode = .Lines(1, .CountOfLines)
        End With
        wbTarget.VBProject.VBComponents("ThisWorkbook").CodeModule.AddFromString sCode
    Application.ScreenUpdating = True
End Sub

Sub RemoveAllMacros(wbk As Workbook)
    Dim vbCode As Object, vbComp As Object, vbProj As Object
    Set vbProj = wbk.VBProject
    With vbProj
        For Each vbComp In .VBComponents
            Select Case vbComp.Type
                Case 1, 2, 3
                    vbProj.VBComponents.Remove vbComp
                Case 100
                    Set vbCode = vbComp.CodeModule
                    vbCode.DeleteLines 1, vbCode.CountOfLines
            End Select
        Next vbComp
    End With
End Sub