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

Question

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

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

Answer 1

你需要寻找到VBComponents来完成这种任务的

你首先需要激活所谓的“Microsoft Visual Basic的应用程序扩展”

试试下面的代码参考：

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。当你以中断模式（或逐行？）运行它时，它会在代码复制后立即生成一个错误。您需要一次运行它..

此代码适用于Excel 2003，可能存在一些安全问题，但我在更高版本上运行它时没有意识到。

Answer 2

没有直接的方法将模块从一个项目复制到另一个项目。要完成此任务，必须从Source VBProject中导出模块，然后将该文件导入到Destination 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 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