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

Question

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

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

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

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

'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

对于这种类型的远程更改，必须小心谨慎。首先尝试代码只复制目标文件并确认正常工作等总是明智的。
它仅适用于未 protected VBA 项目的文件。对于带有 protected VBA 文件的文件，请参阅 SO 帖子 Unprotect VBProject from VB code .