编写将宏写入另一个 Excel 文件的宏

Question

我有一些 VBA 代码需要复制到很多工作表中（它是事件处理，所以它位于工作表中而不是模块中）。

问题：是否可以编写一个宏，让我选择所有需要修改的工作簿，然后自动将代码写入所有选定工作簿的每个工作表？

Answer 1

没有直接的方法可以将模块从一个项目复制到另一个项目。要完成此任务，您必须从源 VBProject 导出模块，然后将该文件导入目标 VBProject。下面的代码将执行此操作。

函数声明为：

Function CopyModule(ModuleName As String, _
                    FromVBProject As VBIDE.VBProject, _
                    ToVBProject As VBIDE.VBProject, _
                    OverwriteExisting As Boolean) As Boolean

ModuleName 是您要从一个项目复制到另一个项目的模块的名称。

FromVBProject 是包含要复制的模块的VBProject。这是来源VBProject。

ToVBProject 是模块要复制到的VBProject。这是目的地VBProject。

OverwriteExisting 表示如果ModuleName 已经存在于ToVBProject 中，该怎么办。如果这是True，则现有的VBComponent 将从ToVBProject 中删除。如果这是False 并且VBComponent 已经存在，则该函数什么都不做并返回False。

如果成功，该函数返回True，如果发生错误，则返回False。如果满足以下任一条件，该函数将返回 False：

FromVBProject is nothing.
ToVBProject is nothing.
ModuleName is blank.
FromVBProject is locked.
ToVBProject is locked.
ModuleName does not exist in FromVBProject.
ModuleName exists in ToVBProject and OverwriteExisting is False.

完整代码如下：

Function CopyModule(ModuleName As String, _
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CopyModule
    ' This function copies a module from one VBProject to
    ' another. It returns True if successful or  False
    ' if an error occurs.
    '
    ' Parameters:
    ' --------------------------------
    ' FromVBProject         The VBProject that contains the module
    '                       to be copied.
    '
    ' ToVBProject           The VBProject into which the module is
    '                       to be copied.
    '
    ' ModuleName            The name of the module to copy.
    '
    ' OverwriteExisting     If True, the VBComponent named ModuleName
    '                       in ToVBProject will be removed before
    '                       importing the module. If False and
    '                       a VBComponent named ModuleName exists
    '                       in ToVBProject, the code will return
    '                       False.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim VBComp As VBIDE.VBComponent
    Dim FName As String
    Dim CompName As String
    Dim S As String
    Dim SlashPos As Long
    Dim ExtPos As Long
    Dim TempVBComp As VBIDE.VBComponent

    '''''''''''''''''''''''''''''''''''''''''''''
    ' Do some housekeeping validation.
    '''''''''''''''''''''''''''''''''''''''''''''
    If FromVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If

    If Trim(ModuleName) = vbNullString Then
        CopyModule = False
        Exit Function
    End If

    If ToVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If

    If FromVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If

    If ToVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If

    On Error Resume Next
    Set VBComp = FromVBProject.VBComponents(ModuleName)
    If Err.Number <> 0 Then
        CopyModule = False
        Exit Function
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FName is the name of the temporary file to be
    ' used in the Export/Import code.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    FName = Environ("Temp") & "\" & ModuleName & ".bas"
    If OverwriteExisting = True Then
        ''''''''''''''''''''''''''''''''''''''
        ' If OverwriteExisting is True, Kill
        ' the existing temp file and remove
        ' the existing VBComponent from the
        ' ToVBProject.
        ''''''''''''''''''''''''''''''''''''''
        If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
            Err.Clear
            Kill FName
            If Err.Number <> 0 Then
                CopyModule = False
                Exit Function
            End If
        End If
        With ToVBProject.VBComponents
            .Remove .Item(ModuleName)
        End With
    Else
        '''''''''''''''''''''''''''''''''''''''''
        ' OverwriteExisting is False. If there is
        ' already a VBComponent named ModuleName,
        ' exit with a return code of False.
        ''''''''''''''''''''''''''''''''''''''''''
        Err.Clear
        Set VBComp = ToVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            If Err.Number = 9 Then
                ' module doesn't exist. ignore error.
            Else
                ' other error. get out with return value of False
                CopyModule = False
                Exit Function
            End If
        End If
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Do the Export and Import operation using FName
    ' and then Kill FName.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    FromVBProject.VBComponents(ModuleName).Export Filename:=FName

    '''''''''''''''''''''''''''''''''''''
    ' Extract the module name from the
    ' export file name.
    '''''''''''''''''''''''''''''''''''''
    SlashPos = InStrRev(FName, "\")
    ExtPos = InStrRev(FName, ".")
    CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)

    ''''''''''''''''''''''''''''''''''''''''''''''
    ' Document modules (SheetX and ThisWorkbook)
    ' cannot be removed. So, if we are working with
    ' a document object, delete all code in that
    ' component and add the lines of FName
    ' back in to the module.
    ''''''''''''''''''''''''''''''''''''''''''''''
    Set VBComp = Nothing
    Set VBComp = ToVBProject.VBComponents(CompName)

    If VBComp Is Nothing Then
        ToVBProject.VBComponents.Import Filename:=FName
    Else
        If VBComp.Type = vbext_ct_Document Then
            ' VBComp is destination module
            Set TempVBComp = ToVBProject.VBComponents.Import(FName)
            ' TempVBComp is source module
            With VBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
                .InsertLines 1, S
            End With
            On Error GoTo 0
            ToVBProject.VBComponents.Remove TempVBComp
        End If
    End If
    Kill FName
    CopyModule = True
End Function

Answer 2

您需要查看 VBComponents 来完成此类任务

您首先需要激活名为“Microsoft Visual Basic for Applications Extensibility”的引用

试试下面的代码：

Sub Test_InsertCode()

    Dim Commands As String
    Commands = Chr(13) & _
                "Private Sub TestNewCode()" & Chr(13) & _
                "    MsgBox ""You Win !!""" & Chr(13) & _
                "End Sub"

    Dim VBComps As VBComponents
    Set VBComps = ThisWorkbook.VBProject.VBComponents

    Dim VBComp As VBComponent
    Dim VBCodeMod As CodeModule

    Dim oSheet As Worksheet
    For Each oSheet In ThisWorkbook.Worksheets
        Set VBComp = VBComps(oSheet.CodeName)
        Set VBCodeMod = VBComp.CodeModule
        InsertCode VBCodeMod, Commands
    Next oSheet

    'Here's a quick example of how to insert code in a new Module
    Set VBComp = VBComps.Add(vbext_ct_StdModule)
    InsertCode VBComp.CodeModule, Commands

End Sub

Private Function InsertCode(VBCodeMod As CodeModule, Commands As String)

    Dim LineNum As Long
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, Commands
    End With

End Function

注意。当您在中断模式下运行它时，（或逐行？）它会在复制代码后立即生成一个错误。你需要一次运行它..

此代码适用于 Excel 2003，在更高版本上运行时可能存在一些我不知道的安全问题。

Answer 3

这不会解决工作表中的事件部分，但这是将模块从一个工作簿移动到另一个工作簿的简单解决方案。

注意 - 您确实需要打开“Microsoft Visual Basic for Applications Extensibility”引用，如上所述。

简而言之，代码可以正常工作（无需所有内务验证）。显然，您可以获得更高级和防错/处理，但这是基础。该函数将模块从您的 FromVBProject 导出到文件目录，然后导入到您的 ToVBProject。

Function CopyModule (ModuleName as String, FromVBProject as VBIDE.VBProject, _  
                     ToVBProject as VBIDE.VBProject, _ 
                     FileLocation as String) as Boolean
Dim fileDirectory as String

fileDirectory = filelocation & ModuleName & ".bas"
FromVBProject.VBComponents.Item(ModuleName).Export fileDirectory
ToVBProject.Import fileDirectory

Kill fileDirectory

CopyModule = True

End Function

Sub CopyModuleToOtherWorkbook()

Dim destinationWorkbook as Workbook
Set destinationWorkbook = Workbooks("destiationWorkbook.xlsm")

CopyModule "TestModule", ThisWorkbook.VBProject, destinationWorkbook.VBProject, "C:\my documents\macros\"   

'Assuming you want to save the workbook you just copied the module to
 destinationWorkbook.SaveAs C:\my documents\macros\ & desintationWorkbook.Name, xlOpenXMLWorkbookMacroEnabled

 End sub