含多个Sub的VBA宏如何批量应用至指定文件夹的百余个Excel文件？

问题背景 #

你已经写好了针对单个工作簿的变更追踪宏（包含Workbook_TrackChange、Workbook_SheetChange、Workbook_SheetSelectionChange三个过程），现在想通过循环遍历指定文件夹里的100多个Excel文件，批量应用这个追踪功能。但尝试在遍历循环里用Call Tracker时，代码能正常遍历打开文件，却没有实际执行追踪逻辑。

问题根源 #

你遇到的核心问题是：原来的三个追踪过程是工作簿级的事件过程，它们需要绑定到目标工作簿的事件上才能生效，而不是直接通过Call调用就能触发。直接调用只会执行一次代码，但不会把这些事件注册到目标工作簿中，所以后续的工作表变更/选择操作不会触发追踪逻辑。另外，模块级变量sOldAddress和vOldValue的作用域也局限在原模块，跨工作簿时无法正常工作。

修改后的完整解决方案代码 #

我们需要调整代码逻辑，让每个打开的工作簿都能正确绑定追踪事件。这里提供两种可行方案：

方案1：动态将追踪代码写入目标工作簿的ThisWorkbook模块（推荐，永久生效） #

这种方式会把追踪代码直接添加到每个目标工作簿的ThisWorkbook模块中，保存后，后续打开文件时会自动启用追踪功能。

Sub LoopThroughFiles_AddTrackerCode()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Dim wb As Workbook
    Dim vbProj As VBIDE.VBProject
    Dim vbComp As VBIDE.VBComponent
    Dim codeModule As VBIDE.CodeModule
    Dim codeText As String
    
    ' 定义要添加的追踪代码文本
    codeText = "Option Explicit" & vbCrLf & _
               "Dim sOldAddress As String" & vbCrLf & _
               "Dim vOldValue As Variant" & vbCrLf & vbCrLf & _
               "Public Sub Workbook_TrackChange(Cancel As Boolean)" & vbCrLf & _
               "    Dim Sh As Worksheet" & vbCrLf & _
               "    For Each Sh In ActiveWorkbook.Worksheets" & vbCrLf & _
               "        Sh.PageSetup.LeftFooter = ""&06"" & ActiveWorkbook.FullName & vbLf & ""&A""" & vbCrLf & _
               "    Next Sh" & vbCrLf & _
               "End Sub" & vbCrLf & vbCrLf & _
               "Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCrLf & _
               "    Dim wSheet As Worksheet" & vbCrLf & _
               "    Dim wActSheet As Worksheet" & vbCrLf & _
               "    Dim iCol As Integer" & vbCrLf & _
               "    Set wActSheet = ActiveSheet" & vbCrLf & _
               "    If vOldValue = """" Then Exit Sub" & vbCrLf & _
               "    On Error Resume Next" & vbCrLf & _
               "    Set wSheet = Sheets(""Tracker"")" & vbCrLf & _
               "    If wSheet Is Nothing Then" & vbCrLf & _
               "        Set wActSheet = ActiveSheet" & vbCrLf & _
               "        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = ""Tracker""" & vbCrLf & _
               "    End If" & vbCrLf & _
               "    On Error GoTo 0" & vbCrLf & _
               "    On Error GoTo ErrorHandler" & vbCrLf & _
               "    With Application" & vbCrLf & _
               "        .ScreenUpdating = False" & vbCrLf & _
               "        .EnableEvents = False" & vbCrLf & _
               "    End With" & vbCrLf & _
               "    With Sheets(""Tracker"")" & vbCrLf & _
               "        .Unprotect Password:=""Secret""" & vbCrLf & _
               "        iCol = 1" & vbCrLf & _
               "        If LenB(.Cells(1, iCol).Value) = 0 Then" & vbCrLf & _
               "            .Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array(""Cell Changed"", ""SAP ID"", ""Field Name"", ""Old Field Value"", _" & vbCrLf & _
               "            ""New Field Value"", ""Time of Change"", ""Date Stamp"", ""User"")" & vbCrLf & _
               "            .Cells.Columns.AutoFit" & vbCrLf & _
               "        End If" & vbCrLf & _
               "        With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)" & vbCrLf & _
               "            If Target.Count = 1 Then" & vbCrLf & _
               "                .Offset(0, 1) = Cells(Target.Row, 2)" & vbCrLf & _
               "            End If" & vbCrLf & _
               "            If Target.Count = 1 Then" & vbCrLf & _
               "                .Offset(0, 2) = Cells(1, Target.Column).Value" & vbCrLf & _
               "            End If" & vbCrLf & _
               "            .Value = sOldAddress" & vbCrLf & _
               "            .Offset(0, 3).Value = vOldValue" & vbCrLf & _
               "            If Target.Count = 1 Then" & vbCrLf & _
               "                .Offset(0, 4).Value = Target.Value" & vbCrLf & _
               "            End If" & vbCrLf & _
               "            .Offset(0, 5) = Time" & vbCrLf & _
               "            .Offset(0, 6) = Date" & vbCrLf & _
               "            .Offset(0, 7) = Application.UserName" & vbCrLf & _
               "            .Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous" & vbCrLf & _
               "        End With" & vbCrLf & _
               "        .Protect Password:=""Secret""" & vbCrLf & _
               "    End With" & vbCrLf & _
               "ErrorExit:" & vbCrLf & _
               "    With Application" & vbCrLf & _
               "        .ScreenUpdating = True" & vbCrLf & _
               "        .EnableEvents = True" & vbCrLf & _
               "    End With" & vbCrLf & _
               "    wActSheet.Activate" & vbCrLf & _
               "    Exit Sub" & vbCrLf & _
               "ErrorHandler:" & vbCrLf & _
               "    Resume ErrorExit" & vbCrLf & _
               "End Sub" & vbCrLf & vbCrLf & _
               "Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbCrLf & _
               "    With Target" & vbCrLf & _
               "        sOldAddress = .Address(external:=True)" & vbCrLf & _
               "        If .Count > 1 Then" & vbCrLf & _
               "            vOldValue = ""Multiple Cell Select""" & vbCrLf & _
               "        Else" & vbCrLf & _
               "            vOldValue = .Value" & vbCrLf & _
               "        End If" & vbCrLf & _
               "    End With" & vbCrLf & _
               "End Sub"
    
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")
        
        ' 提示：需要先在Excel选项-信任中心-信任中心设置-宏设置中勾选"信任对VBA项目对象模型的访问"
        Do While xFileName <> ""
            Set wb = Workbooks.Open(xFdItem & xFileName)
            On Error Resume Next
            Set vbProj = wb.VBProject
            On Error GoTo 0
            
            If Not vbProj Is Nothing Then
                Set vbComp = vbProj.VBComponents("ThisWorkbook")
                Set codeModule = vbComp.CodeModule
                
                ' 先清空原有可能存在的追踪代码（可选）
                codeModule.DeleteLines 1, codeModule.CountOfLines
                ' 添加新的追踪代码
                codeModule.AddFromString codeText
                
                ' 执行一次初始化（设置页脚）
                wb.Application.Run "ThisWorkbook.Workbook_TrackChange", False
            End If
            
            ' 保存并关闭工作簿
            wb.Save
            wb.Close SaveChanges:=False
            xFileName = Dir
        Loop
        MsgBox "批量添加追踪代码完成！"
    End If
End Sub

方案2：临时绑定事件（仅在本次打开时生效） #

如果你不想修改目标工作簿的代码，只是想在本次遍历打开时临时启用追踪，可以用类模块绑定事件的方式，但相对复杂一些：

• 创建一个类模块（比如命名为clsWorkbookEvents），在类模块中声明工作簿对象并绑定事件；
• 在遍历循环中，为每个打开的工作簿创建类实例，绑定事件；
• 注意需要保持类实例的引用，避免被垃圾回收。

关键注意事项 #

• 宏安全设置：方案1需要启用“信任对VBA项目对象模型的访问”，否则无法修改目标工作簿的VBA代码。路径：Excel选项 > 信任中心 > 信任中心设置 > 宏设置 > 勾选信任对VBA项目对象模型的访问。
• 代码调整：我对你原来的Workbook_SheetChange代码做了一处小修改：.Offset(0, 2) = Cells(1, Target.Column).Value，原来的Cells(Target.Column)会取当前活动单元格所在行的对应列，改成取第1行的列标题更符合“Field Name”的需求，如果你不需要可以改回。
• 密码保护：代码中的Tracker工作表密码是Secret，如果需要修改请统一替换。

内容的提问来源于stack exchange，提问作者KS_08