我必须对＆gt; 100 XLSM文件中使用的现有宏进行细微更改。宏在本地保存在文件中，并且在所有文件中具有相同的名称。 有没有办法实现自动化？
我知道将此宏存储在单独的工作表中会更好... 请求的原因正是我们要切换到中央宏并更改本地＆＃39;宏观代码呼叫中心＆＃39;之一。
答案 0 :(得分：4)
两次阅读 - tweeted about this just the other day
然后按照以下顺序：
答案 1 :(得分：0)
这是我最终用于更改一个宏并在“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
答案 2 :(得分：0)
我遇到了Sub Workbook_BeforeSave的问题：在大量旧文件中，如果Excel版本不是Excel 2007，则此功能无法保存它。（即使使用Excel 2013或2016也不会保存文件）。
删除子文件（“Excel已停止工作......”）后立即将文件保存到另一个文件夹（.SaveAs）时，删除旧的Sub Workbook_BeforeSave但Excel（至少Excel 2016）的操作非常简单。 ）。然后我尝试不删除整个子，但只是它的内容（'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个变量，start和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