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

Writing a macro that writes a macro to another Excel-file

提问by beerskij

I have some VBA code that I need to copy to a lot of worksheets (it's Event-handling, so it's located in the sheets rather than a module).

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

Question: Is it possible to write a macro that allows me to select all the workbooks I need to modify, then automatically write the code to every sheet of all of the selected workbooks?

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

回答by Avishek Pandey

There is no direct way to copy a module from one project to another. To accomplish this task, you must export the module from the Source VBProject and then import that file into the Destination VBProject. The code below will do this.

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

The function declaration is:

函数声明是：

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

ModuleNameis the name of the module you want to copy from one project to another.

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

FromVBProjectis the VBProjectthat contains the module to be copied. This is the source VBProject.

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

ToVBProjectis the VBProjectin to which the module is to be copied. This is the destination VBProject.

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

OverwriteExistingindicates what to do if ModuleNamealready exists in the ToVBProject. If this is Truethe existing VBComponentwill be removed from the ToVBProject. If this is Falseand the VBComponentalready exists, the function does nothing and returns False.

OverwriteExisting指示做什么，如果ModuleName在已经存在ToVBProject。如果是这样True，现有的VBComponent将从ToVBProject. 如果 this isFalse并且VBComponent已经存在，则该函数不执行任何操作并返回False。

The function returns Trueif successful or Falseif an error occurs. The function will return Falseif any of the following are true:

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.

The complete code is shown below:

完整代码如下所示：

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

回答by FlatEarth

you need to look into the VBComponents to accomplish this kind of tasks

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

You first need to activate the reference called "Microsoft Visual Basic for Applications Extensibility"

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

Try the following code:

试试下面的代码：

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

nb. when you run it in break mode, ( or line by line ? ) it generates a bug right after the code is copied. You need to run it all at once..

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

This code is working for Excel 2003, there might be some security issues that I'm not aware of when running it on later versions.

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

回答by proudestWarehouse89

This won't solve the worksheet, on-event part, but this is a simple solution for moving modules from one workbook to another.

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

Note - You do need the "Microsoft Visual Basic for Applications Extensibility" references turned on as noted one above.

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

In short, the code will work (without all the housekeeping validations). Obviously you can get much fancier and error proof/handling, but this is the basics. The function exports the module to a file directory from your FromVBProject, then imports to your ToVBProject.

简而言之，代码将起作用（无需所有内务验证）。显然，您可以获得更高级的错误证明/处理，但这是基础知识。该函数将模块从 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