Размещение другого ответа, структурированного как обобщенные инструменты для удаления и / или добавления или замены любого количества процедур из любого количества файлов.Как упоминалось ранее, предполагается, что должен быть включен доверительный доступ к проекту Visual Basics.
В новом файле Excel с добавленной ссылкой на Microsoft Visual Basic для расширяемости приложения добавьте модуль с именем «Copy_Module».В вашем случае скопируйте код Worksheet_SelectionChange в модуль с именем «Copy_Module».
Его функция AddReplaceProc будет копировать любую процедуру из модуля с именем «Copy_Module» в исходной книге, в то время как функция DeleteProc удалит процедуру.
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
Надлежащая осторожность обязательна для этого типа дистанционных изменений.Всегда разумно сначала попробовать код только для копий целевых файлов и подтвердить правильность работы и т. Д.
Он работает только с файлами с незащищенными проектами VBA.Для файлов с защищенными файлами VBA см. Сообщение SO Снять защиту VBProject с кода VB .