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 Project的信任访问。

在添加了对Microsoft Visual Basic应用程序可扩展性的引用的新excel文件中，添加一个名为“ Copy_Module”的模块。具体而言，请在名为“ Copy_Module”的模块中复制Worksheet_SelectionChange代码。

其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文件的文件，请参见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 Project的信任访问。

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

2 个答案: