向文件夹中的所有工作簿添加新的和删除旧的 VBA

Question

我有大约 60 个包含多个模块的工作簿，我需要删除一个模块中的一个子例程，然后将代码添加到特定工作表。

我目前每次打开工作簿时都会运行代码，要求运行并将数据存档到另一个工作表，它可以工作。 问题是我们多次出现在工作簿中，所以每次打开它们时，我们都必须回答问题。

当我转到第一个工作表时，我找到了一种更优雅的方式来要求存档，我们将在月底更改数据。 只有当我们打开它时，我们才需要存档旧数据。 有时我们会去这里查看数据，但这并不常见。 我现在有用于选择的特定工作表的新代码，该代码有效。

我正在尝试更新所有工作簿中的代码，而不必逐一打开它们并进行更改、复制、粘贴、删除、保存、打开下一个文件、重复。

'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

我想删除第一个子项，然后将第二个子项添加到特定工作表（在所有工作簿中命名相同）。 然后，如果我将来有更改，我可以轻松地使用其他更改更新我的所有工作簿。

Answer 1

发布另一个结构为通用工具的答案，用于从任意数量的文件中删除和/或添加或替换任意数量的程序。 如前所述，假设必须启用对 Visual Basics 项目的信任访问。

在添加了对 Microsoft Visual Basic for Application 可扩展性的引用的新 Excel 文件中，添加名为“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 post Unprotect VBProject from VB code 。

Answer 2

尝试任何工作簿（不在同一目标文件夹中）模块中的代码。 添加对 Microsoft Visual Basic 应用程序可扩展性的引用。 和/或使vbext_pk_Proc为 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

但是，如果规定的工作表、代码模块和程序不可用，代码将遇到错误。 如果未确认所有目标文件中所述工作表、代码模块和程序的可用性，请务必小心。 （可以使用错误处理程序或通过在打开目标文件后迭代并相应跳过来检查 Sheets、代码模块和程序是否存在） 。 还必须启用对 Visual Basics 项目的信任访问。