Adding new and removing old VBA to all workbooks in a folder

Question

I have about 60 workbooks with several modules and I need to remove one sub routine in one module then add code to a specific worksheet.

I currently have code running every time you open the workbook asking to run and archive data to another worksheet, it works. Problem is we are in the workbooks several times, so every time we open them, we have to answer the question.

I found a more elegant way to ask to archive when I go to the first worksheet where we go to change data at the end of the month. Only when we open this are we needing to archive the old data. Some times we go here to look at the data, but it's not the usual. I have new code now for the specific worksheet using on select, that works.

I'm trying to update the code across all my workbooks without having to open them up 1 by 1 and make the changes, copy, paste, delete, save, open next file, repeat.

'code to remove from module named ArchiveHistoricalData  
Sub Auto_Open()
AskArchive
End Sub


'Code to add to worksheet named Data Dump
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
AskArchive
End Sub

I'd like to remove the first sub, then add the second sub to a specific worksheet (Named the same across all workbooks). Then if I have changes in the future, I can easily update all my workbooks with other changes.

Answer 1

Posting another answer structured as generalized tools to delete and/or add or replace any number of procedures from any number of files. As mentioned earlier it is assumed that Trust Access to Visual Basics Project must be enabled.

In a new excel file with added reference to Microsoft Visual Basic for Application extensibility, add a module named “Copy_Module”. Specifically in your case, copy Worksheet_SelectionChange code in a module named “Copy_Module”.

Its AddReplaceProc function would copy any procedure from a module named “Copy_Module” in the source workbook while DeleteProc function would delete a procedure.

Sub test4()
Dim Wb As Workbook, ws As Worksheet
Dim Path As String, Fname As String
Dim Fno As Long

Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")

    Fno = 1
    Do While Fname <> ""
    Set Wb = Application.Workbooks.Open(Path & Fname)

        If Wb.VBProject.Protection = vbext_pp_none Then
        Set ws = ThisWorkbook.ActiveSheet
        Fno = Fno + 1
        ws.Cells(Fno, 1).Value = Fname
        'ws.Cells(Fno, 2).Value = AddReplaceProc(Wb, "ArchiveHistoricalData", "DoStuff2")
        ws.Cells(Fno, 2).Value = DeleteProc(Wb, "ArchiveHistoricalData", "Auto_Open")
        ws.Cells(Fno, 3).Value = AddReplaceProc(Wb, Wb.Worksheets("Data Dump").CodeName, "Worksheet_SelectionChange")
        Wb.Close True
        Else
        Wb.Close False
        End If

    Fname = Dir
    Loop
End Sub
Private Function DeleteProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
DeleteProc = False
    For Each Vbcomp In Wb.VBProject.VBComponents
        If Vbcomp.Name = CompName Then
        Set Vbc = Vbcomp.CodeModule
            On Error GoTo XExit
            If Vbc.ProcStartLine(ProcName, 0) > 0 Then
            Vbc.DeleteLines Vbc.ProcStartLine(ProcName, 0), Vbc.ProcCountLines(ProcName, 0)
            DeleteProc = True
            Exit For
            End If
        End If
    Next Vbcomp
XExit: On Error GoTo 0
End Function
Private Function AddReplaceProc(Wb As Workbook, CompName As String, ProcName As String) As Boolean
Dim Vbc As CodeModule, Vbcomp As VBComponent
Dim VbcSrc As CodeModule, StLine As Long, EndLine As Long
Dim i As Long, X As Long
'Check for older version of the procedure and delete the same before coping new version
AddReplaceProc = DeleteProc(Wb, CompName, ProcName)
Debug.Print "Old Proc " & ProcName & " Found and Deleted : " & AddReplaceProc
AddReplaceProc = False

    For Each Vbcomp In Wb.VBProject.VBComponents
        If Vbcomp.Name = CompName Then
        Set Vbc = Vbcomp.CodeModule
        Set VbcSrc = ThisWorkbook.VBProject.VBComponents("Copy_Module").CodeModule
        StLine = VbcSrc.ProcStartLine(ProcName, 0)
        EndLine = StLine + VbcSrc.ProcCountLines(ProcName, 0) - 1
            X = 0
            For i = StLine To EndLine
            X = X + 1
            Vbc.InsertLines X, VbcSrc.Lines(i, 1)
            Next i
        AddReplaceProc = True
        Exit For
        End If
    Next Vbcomp

End Function

Proper caution is a must for this type of remote changes. It is always wise to try the code first only to copies of target files and confirm proper working etc.
It only works with files with unprotected VBA projects. For files with protected VBA files refer SO post Unprotect VBProject from VB code.

Answer 2

Try the code from any workbook (not in the same target folder) module. Add reference to Microsoft visual basic for applications extensibility. and/or make vbext_pk_Proc as 0.

Sub test3()
Dim ws As Workbook
Dim Vbc As CodeModule
Dim Path As String, Fname As String

Dim Wx As Worksheet
Dim HaveAll As Boolean
Dim VbComp As VBComponent


Path = "C:\Users\User\Documents\TestFolder\"
Fname = Dir(Path & "*.xlsm")

    Do While Fname <> ""
'    Debug.Print Fname
    Set ws = Application.Workbooks.Open(Path & Fname)
    HaveAll = False

         For Each VbComp In ws.VBProject.VBComponents
            If VbComp.Name = "ArchiveHistoricalData" Then
                'used erron handler instead of iterating through all the lines for keeping code short
                On Error GoTo failex
                If VbComp.CodeModule.ProcStartLine("Auto_Open", 0) > 0 Then
                HaveAll = True
failex:         Resume failex2
failex2:        On Error GoTo 0
                Exit For
                End If
             End If
         Next VbComp


         If HaveAll Then
         HaveAll = False
         For Each Wx In ws.Worksheets
            If Wx.Name = "Data Dump" Then
            HaveAll = True
            Exit For
            End If
         Next Wx
         End If


        If HaveAll Then
        Set Vbc = ws.VBProject.VBComponents("ArchiveHistoricalData").CodeModule
        Vbc.DeleteLines Vbc.ProcStartLine("Auto_Open", vbext_pk_Proc), Vbc.ProcCountLines("Auto_Open", vbext_pk_Proc)
        Set Vbc = ws.VBProject.VBComponents(ws.Worksheets("Data Dump").CodeName).CodeModule
        Vbc.InsertLines 1, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
        Vbc.InsertLines 2, "AskArchive"
        Vbc.InsertLines 3, "End Sub"
        ws.Close True
        Else
        ws.Close False
        End If
    Debug.Print Fname, HaveAll

    Fname = Dir
    Loop

End Sub

However code will encounter error if the stated Worksheets, code modules and procedures are not available. Please take due care, if not confirmed about availability of the stated Worksheets, code modules and procedures in all the target files. (may use error handler or check for existence for the Sheets, code modules and procedures by iterating through after opening the target file and skip accordingly). Also Trust Access To Visual Basics Project must be enabled.