編寫一個將宏寫入另一個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