如何让VBA宏批量应用于指定文件夹内所有Excel工作簿

一、重构现有子过程，消除对Active对象的依赖 #

原有代码大量依赖ActiveSheet/ActiveWorkbook/Select/Activate这类不稳定的操作，批量处理多工作簿时很容易出现对象指向错误，需要把所有子过程改为显式传入工作簿/工作表参数，所有单元格、工作表操作都绑定到指定对象：

' 修改后行求和逻辑，传入目标工作表
Sub SumRowsValues(ws As Worksheet)
    Dim i As Long
    For i = 4 To 44
        If Application.WorksheetFunction.Sum(ws.Range(ws.Cells(i, 3), ws.Cells(i, 10))) <> 0 Then
            ws.Cells(i, 11) = 15
        End If
    Next i
End Sub

' 修改后列求和逻辑，传入目标工作表
Sub SumColumnsValues(ws As Worksheet)
    Dim i As Long
    For i = 3 To 11
        ws.Cells(45, i) = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(4, i), ws.Cells(44, i)))
    Next i
End Sub

' 修改后新建汇总表逻辑，传入目标工作簿
Sub AddTotalSheet(wb As Workbook)
    wb.Sheets.Add(Before:=wb.Sheets("Mon")).Name = "Weekly Totals"
End Sub

' 修改后数据拷贝逻辑，传入目标工作簿
Sub CopyFromWorksheets(wb As Workbook)
    With wb.Worksheets("Weekly Totals")
        .Range("A1").Value = "Date"
        .Range("B1").Value = "Person"
        .Range("C1").Value = "Day"
        wb.Worksheets("Mon").Range("C3:K3").Copy .Range("D1")
        wb.Worksheets("Mon").Range("C45:K45").Copy .Range("D2")
        wb.Worksheets("Tue").Range("C45:K45").Copy .Range("D3")
        wb.Worksheets("Wed").Range("C45:K45").Copy .Range("D4")
        wb.Worksheets("Thu").Range("C45:K45").Copy .Range("D5")
        wb.Worksheets("Fri").Range("C45:K45").Copy .Range("D6")
    End With
End Sub

' 修改后工作表名填充逻辑，传入目标工作簿
Sub ListSheetNames(wb As Workbook)
    Dim ws As Worksheet, rowIndex As Long
    rowIndex = 2
    For Each ws In wb.Worksheets
        If ws.Name <> "Weekly Totals" Then
            wb.Sheets("Weekly Totals").Cells(rowIndex, 3) = ws.Name
            rowIndex = rowIndex + 1
        End If
    Next
End Sub

' 修改后文件名解析逻辑，传入目标工作簿
Sub GetFileName(wb As Workbook)
    Dim strFileFullName As String, DateText, NameText
    strFileFullName = wb.Name
    DateText = Split(strFileFullName, "_")
    NameText = Split(strFileFullName, ".")
    With wb.Worksheets("Weekly Totals")
        .Range("A2").Value = DateText(0)
        .Range("B2").Value = NameText(0)
    End With
End Sub

' 修改后姓名提取逻辑，传入目标工作簿
Sub RemoveTextBeforeUnderscore(wb As Workbook)
    Dim i As Long, cell As Range
    With wb.Worksheets("Weekly Totals")
        For i = 2 To 6
            Set cell = .Range("B" & i)
            cell.Value = Split(.Range("B2").Value, "_")(1)
        Next i
    End With
End Sub

' 修改后日期填充逻辑，传入目标工作簿
Sub StringToDate(wb As Workbook)
    Dim InitialValue As Long, DateAsString As String, FinalDate As Date
    With wb.Worksheets("Weekly Totals")
        InitialValue = .Range("A2").Value
        DateAsString = CStr(InitialValue)
        FinalDate = DateSerial(CInt(Left(DateAsString, 4)), CInt(Mid(DateAsString, 5, 2)), CInt(Right(DateAsString, 2)))
        .Range("A2").Value = FinalDate
        .Range("A3").Value = FinalDate + 1
        .Range("A4").Value = FinalDate + 2
        .Range("A5").Value = FinalDate + 3
        .Range("A6").Value = FinalDate + 4
        .Columns("A").AutoFit
    End With
End Sub

' 修改后单工作簿汇总入口，传入目标工作簿
Sub DoEverything(wb As Workbook)
    Dim ws As Worksheet
    ' 先删除已存在的汇总表避免重复创建报错
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Sheets("Weekly Totals").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    For Each ws In wb.Worksheets
        SumRowsValues ws
        SumColumnsValues ws
    Next ws
    AddTotalSheet wb
    CopyFromWorksheets wb
    ListSheetNames wb
    GetFileName wb
    RemoveTextBeforeUnderscore wb
    StringToDate wb
    wb.Save
End Sub

二、新增批量调度主过程 #

直接在Personal.xlsb中添加以下代码，运行后可自由选择两种处理模式：处理已打开的所有工作簿，或选择指定文件夹批量处理所有符合要求的xlsx文件：

Sub BatchProcessWorkbooks()
    Dim choice As VbMsgBoxResult
    choice = MsgBox("选择处理模式：点击「是」选择指定文件夹批量处理，点击「否」处理当前所有已打开工作簿", vbYesNoCancel, "批量汇总")
    If choice = vbCancel Then Exit Sub
    
    ' 关闭屏幕刷新提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo ErrHandler
    
    If choice = vbYes Then
        ' 模式1：选择文件夹批量处理
        Dim folderDlg As FileDialog
        Set folderDlg = Application.FileDialog(msoFileDialogFolderPicker)
        With folderDlg
            .Title = "请选择待处理Excel文件所在文件夹"
            If .Show <> -1 Then GoTo ExitSub
            Dim folderPath As String
            folderPath = .SelectedItems(1) & "\"
        End With
        
        Dim fileName As String
        fileName = Dir(folderPath & "*.xlsx")
        Do While fileName <> ""
            ' 跳过自身配置文件
            If fileName <> "Personal.xlsb" Then
                Dim wb As Workbook
                Set wb = Workbooks.Open(folderPath & fileName)
                DoEverything wb
                wb.Close SaveChanges:=True
            End If
            fileName = Dir
        Loop
    Else
        ' 模式2：处理已打开的所有工作簿
        Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name <> "Personal.xlsb" Then
                DoEverything wb
            End If
        Next wb
    End If
    
    MsgBox "批量处理完成！", vbInformation
    
ExitSub:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
ErrHandler:
    MsgBox "处理出错：" & Err.Description, vbCritical
    Resume ExitSub
End Sub

三、使用说明 #

所有修改后的代码仍保存在Personal.xlsb中，需要批量处理时直接运行BatchProcessWorkbooks宏，按照弹窗提示选择对应模式即可。

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