如何更改许多Excel工作簿中的单个macros？

我必须对在> 100个XLSM文件中使用的现有macros进行较小的更改。 macros在本地保存在文件中，并在所有文件中具有相同的名称。 有没有办法让这个自动化？

我知道将这个macros存储在一个单独的表格中会更好。请求的原因正是我们想要切换到中央macros，并将“本地”macros代码更改为“中央”macros。

Answer 1

阅读两次 – http://www.cpearson.com/excel/vbe.aspx

然后按照这个顺序：

• 用新的“macros”创build一个新的模块。
• 用旧的“macros”循环所有的文件。
• 使用旧的“macros” 删除模块 （请参阅从项目中删除模块 ）
• 添加新的模块与新的“macros”。 （请参阅将模块从一个项目复制到另一个项目 ）

Answer 2

这是我最终用来更改一个macros的代码，并在“ThisWorkbook”中添加一个

Sub UpdateAllFiles() Dim folderPath As String Dim wb As Workbook Dim Files As New Collection Dim FileName As Variant 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False folderPath = "C:\MyFolder" 'MUST BE CHANGED If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" FileName = Dir(folderPath & "*.xlsm") Do While FileName <> "" Files.Add FileName FileName = Dir Loop For Each FileName In Files Set wb = Workbooks.Open(folderPath & FileName) 'Call a subroutine here to operate on the just-opened workbook Call ChangeMacros ' Close file wb.Close SaveChanges:=True Next FileName 'Reset Macro Optimization Settings Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub ChangeMacros() ' change macro MyMacro ChangeIsSucces = CopyModule("MyMacro", ThisWorkbook.VBProject, ActiveWorkbook.VBProject, True) If ChangeIsSucces = False Then MsgBox "Failed on " & ThisWorkbook.Name End If ' Add Onsave macro (Can be done more aefficiently without any doubt) Dim CodePan As VBIDE.CodeModule Dim S As String Set CodePan = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule S = _ "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)" & vbNewLine & _ " Dim relativePath As String" & vbNewLine & _ " relativePath = ThisWorkbook.Path & ""\_MacroBook_.xlsb""" & vbNewLine & _ " Workbooks.Open Filename:=relativePath" & vbNewLine & _ " ThisWorkbook.Activate" & vbNewLine & _ " Application.Run (""'_MacroBook_.xlsb'!ExportPlanning"")" & vbNewLine & _ " Workbooks(""_MacroBook_.xlsb"").Close SaveChanges:=False" & vbNewLine & _ "End Sub" With CodePan .InsertLines .CountOfLines + 1, S End With End Sub Function CopyModule(ModuleName As String, _ FromVBProject As VBIDE.VBProject, _ ToVBProject As VBIDE.VBProject, _ OverwriteExisting As Boolean) As Boolean ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Credits to http://www.cpearson.com/excel/vbe.aspx ' ' 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

我遇到了Sub Workbook_BeforeSave的问题：如果Excel版本不是Excel 2007，那么在许多旧文件中，此function会阻止保存它。（即使使用Excel 2013或2016，也不会保存文件）。

删除旧的Sub Workbook_BeforeSave已经足够简单了，但是当删除子文件（“Excel has stopped working …”）后，文件保存到另一个文件夹（.SaveAs）时，Excel（至lessExcel 2016）就起作用了。 然后，我试图不删除整个sub，但只是它的内容（'Sub'和'End Sub'之间的所有行，导致Excel停滞。

也重新编译

  Dim objVBECommandBar As Object Dim compileMe As Object Set objVBECommandBar = Application.VBE.CommandBars Set compileMe = objVBECommandBar.FindControl(Type:=msoControlButton, ID:=578) compileMe.Execute 'the project should hence be compiled 

没有帮助 我怀疑操作代码模块后Excel函数地址表不匹配。

有什么帮助是注释Sub Workbook_BeforeSave（…）的内容，即保持

  Sub Workbook_BeforeSave (...) 

和

  End Sub 

…并将所有内容作为评论。

  Function CommentOutProcedureContent(filename As String, moduleName As String, procName As String) As Variant Dim module As CodeModule Dim start As Long Dim realStart As Long Dim Lines As Long Dim rowIdx As Long Dim thisLine As String Dim tmpStr As String Set module = Workbooks(filename).VBProject.VBComponents(moduleName).CodeModule On Error Resume Next Err.Clear With module start = .ProcStartLine(procName, vbext_pk_Proc) If Err.Number = 0 Then Lines = .ProcCountLines(procName, vbext_pk_Proc) ' find the real 'function' or 'sub' beginning realStart = start If .Find("Sub " & procName, realStart, 1, start + Lines, -1) Then '=> realStart now has the real line number ElseIf .Find("Function " & procName, realStart, 1, start + Lines, -1) Then '=> realStart now has the real line number Else Err.Raise 999 End If If Err.Number = 0 Then For rowIdx = (realStart + 1) To (Lines + start - 2) tmpStr = module.Lines(rowIdx, 1) .DeleteLines rowIdx .InsertLines rowIdx, "'" & tmpStr Next rowIdx End If End If End With CommentOutProcedureContent = Err.Number On Error GoTo 0 End Function 

需要2个variablesstart和realStart来自于这样的事实：module.ProcStartLine（…）返回前一个函数/ sub的“End Sub”之后的下一个行号，而不是“Sub Workbook_BeforeSave …）”。

所以上层看起来像这样：

  Function DisableWorkbookBeforeSave(filename As String) As Variant Const thisFunction = "DisableWorkbookBeforeSave" Dim objVBECommandBar As Object Dim compileMe As Object Dim varTMP As Variant Dim errMsg As String Application.DisplayAlerts = False errMsg = "" varTMP = CommentOutProcedureContent(filename, "ThisWorkbook", "Workbook_BeforeSave") If varTMP = 0 Then ' everything's ok Application.Workbooks(LDRFilename).Activate Set objVBECommandBar = Application.VBE.CommandBars Set compileMe = objVBECommandBar.FindControl(Type:=msoControlButton, ID:=578) compileMe.Execute 'the project should hence be compiled Else errMsg = thisFunction & " ended with ERROR! Commenting out Sub Workbook_BeforeSave" _ & " in LDR >" & LDRFilename & "< failed." _ & " with error " & Err.Number & "(" & Err.Description & ")" write2log errMsg, 1 MsgBox errMsg End If DisableWorkbookBeforeSave = varTMP End Function