How to change a single macro in many excel workbooks?

Question

I have to make a minor change to an existing macro that is used in >100 XLSM files. The macro is saved locally in the files and has the same name in all files. Is there a way to automate this?

I know it would have been better to store this macro in a separate sheet... The reason for the request is exactly that we want to switch to a central macro and change the 'local' macro code to call the 'central' one.

Answer 1

Read this twice - http://www.cpearson.com/excel/vbe.aspx

Then follow this sequence:

• create a new module with the new "macro".
• loop through all the files with the old "macro".
• delete the module, with the old "macro" (see Deleting A Module From A Project )
• add the new module with the new "macro". (see Copy A Module From One Project To Another )

Answer 2

This is the code I've ultimately used to change one macro and add one in "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

I had the problem with Sub Workbook_BeforeSave: In a good number of old files this function prevented saving it if the Excel version was not Excel 2007. (ie even with Excel 2013 or 2016 it would not save the file).

It was simple enough to DELETE the old Sub Workbook_BeforeSave but Excel (at least Excel 2016) acted up when the file was saved to another folder (.SaveAs) right after removing the sub ("Excel has stopped working..."). I then tried not to remove the whole sub but just it's content (all lines between 'Sub' and 'End Sub'; that cause Excel to stall.

Also re-compiling with

   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

...didn't help. I suspect a mismatch of the Excel function address table after the manipulation of the code module.

What did help was commenting out the content of Sub Workbook_BeforeSave(...), ie keeping

    Sub Workbook_BeforeSave (...)

and

    End Sub

...and make everything inbetween as comment.

    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

The need for 2 variables, start and realStart, comes from the fact that module.ProcStartLine(...) returns the next line number after the 'End Sub' of the previous function/sub and not the line number of "Sub Workbook_BeforeSave(...)".

So the upper layer looks like this :

    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