当宏包含许多子项时，如何将宏应用于多个Excel文件？

Question

我曾经使用宏来跟踪工作簿中的更改，但是现在我想使用Do While循环在特定文件夹中的100多个excel文件中运行此宏。

我是VBA的新手，将不胜感激。

我遇到了一些代码，这些代码应该使我能够循环浏览文件夹中的excel文件并在每个文件夹中运行宏。

但是，当我将其复制并粘贴到do while循环中时，它需要我摆脱宏中的“ sub”和“ end sub”，但是我在宏中有3个；如果删除全部3，则某些变量将不确定。

因此，我在循环内尝试了“ Call Tracker”（“ Tracker”是宏名称），希望它可以在每个excel文件中运行。

Sub LoopThroughFiles()

    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String

    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*,xls*")
        Do While xFileName <> ""
           With Workbooks.Open(xFdItem & xFileName)
                'Your code here
                Call Tracker
           End With
           xFileName = Dir
        Loop
     End If
End Sub

下面是“跟踪器”中的代码

Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant

Public Sub Workbook_TrackChange(Cancel As Boolean)

    Dim Sh As Worksheet
    For Each Sh In ActiveWorkbook.Worksheets
        Sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
    Next Sh
End Sub

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim wSheet As Worksheet
    Dim wActSheet As Worksheet
    Dim iCol As Integer
    Set wActSheet = ActiveSheet

     'Precursor Exits
     'Other conditions that you do not want to track could be added here
    If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded

     'Continue

    On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
    Set wSheet = Sheets("Tracker")
     '**** Add the tracker Sheet if it does not exist ****


    If wSheet Is Nothing Then
        Set wActSheet = ActiveSheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
    End If
    On Error GoTo 0
     '**** End of specific error resume next

    On Error GoTo ErrorHandler
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With Sheets("Tracker")
         '******** This bit of code moves the tracker over a column when the first columns are full**'
        If .Cells(1, 1) = "" Then '
            iCol = 1 '
        Else '
            iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
         '********* END *****************************************************************************'
        .Unprotect Password:="Secret"

         '******** Sets the Column Headers **********************************************************
        If LenB(.Cells(1, iCol).Value) = 0 Then
            .Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "SAP ID", "Field Name", "Old Field Value", _
            "New Field Value", "Time of Change", "Date Stamp", "User")
            .Cells.Columns.AutoFit
        End If

        With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)

            If Target.Count = 1 Then
                .Offset(0, 1) = Cells(Target.Row, 2) 'SAPID
            End If

            '.Offset(0, 1) = Cells(Target.Row, 2) 'SAPID

            If Target.Count = 1 Then
                .Offset(0, 2) = Cells(Target.Column) 'Field name
            End If

            '.Offset(0, 2) = Cells(Target.Column) 'Field name

            .Value = sOldAddress

            .Offset(0, 3).Value = vOldValue

            If Target.Count = 1 Then
                .Offset(0, 4).Value = Target.Value
            End If

            .Offset(0, 5) = Time
            .Offset(0, 6) = Date
            .Offset(0, 7) = Application.UserName
            .Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
        End With

         .Protect Password:="Secret"  'comment to protect the "tracker tab"

    End With
ErrorExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    wActSheet.Activate
    Exit Sub

ErrorHandler:
     'any error handling you want
     'Debug.Print "We have an error"
    Resume ErrorExit

End Sub

Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    With Target
        sOldAddress = .Address(external:=True)

        If .Count > 1 Then

            vOldValue = "Multiple Cell Select"

        Else

            vOldValue = .Value
        End If
    End With
End Sub

循环中的“呼叫跟踪器”不会产生错误。实际上，该代码似乎可以执行并遍历所有文件，但是在打开的每个文件中都不会运行该宏。