时间戳

首页 > 解决方案 > 将所有 VBA 代码从工作簿复制到另一个

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

问题描述

我搜索了很多，发现了很多导出 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

标签： excelvba

解决方案

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

要将模块从一个工作簿复制到另一个[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

希望有帮助。

推荐阅读