我有一些 VBA 代码需要复制到很多工作表中（它是事件处理，所以它位于工作表中而不是模块中）。
问题：是否可以编写一个宏，允许我选择所有需要修改的工作簿，然后自动将代码写入所有选定工作簿的每张工作表？
问问题
14667 次
3 回答
5
没有直接的方法可以将模块从一个项目复制到另一个项目。要完成此任务，您必须从源 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. 如果 this存在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
于 2014-11-24T10:50:16.767 回答
1
您需要查看 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，在更高版本上运行它时可能存在一些我不知道的安全问题。
于 2012-10-03T15:42:47.217 回答
0
这不会解决工作表、事件部分，但这是将模块从一个工作簿移动到另一个工作簿的简单解决方案。
注意 - 您确实需要打开“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
于 2015-02-06T00:09:12.227 回答