优化宏实现批量匹配筛选工作簿与文件夹多工作簿数据汇总

Hey there! Let's fix that tedious manual macro run issue and make this process efficient, even with those huge 300k-400k row files. Here's a fully automated VBA script that will loop through all Excel files in your target folder, handle the matching, and build your summary table in one go:

Step 1: The VBA Code #

Open your filter workbook, press Alt + F11 to open the VBA editor, insert a new module, and paste this code:

Sub BulkMatchAndSummarize()
    Dim filterWB As Workbook
    Dim summaryWS As Worksheet
    Dim targetFolder As String
    Dim fileName As String
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim s5Data As Variant
    Dim s1Data As Variant
    Dim matchDict As Object
    Dim i As Long, j As Long, lastRowS5 As Long, lastRowS1 As Long, summaryRow As Long
    
    ' Setup: Assign your filter workbook and summary sheet
    Set filterWB = ThisWorkbook
    On Error Resume Next
    Set summaryWS = filterWB.Sheets("Summary")
    On Error GoTo 0
    If summaryWS Is Nothing Then
        ' Create summary sheet if it doesn't exist
        Set summaryWS = filterWB.Sheets.Add(After:=filterWB.Sheets(filterWB.Sheets.Count))
        summaryWS.Name = "Summary"
        ' Optional: Add header row (adjust based on your column needs)
        summaryWS.Range("A1").Value = "S5 Column A"
        ' Add headers for S1 columns here, e.g., summaryWS.Range("B1").Value = "S1 Column A" etc.
    End If
    summaryRow = summaryWS.Cells(summaryWS.Rows.Count, "A").End(xlUp).Row + 1
    
    ' Get target folder path (user selects folder)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder Containing Source Excel Files"
        If .Show = -1 Then
            targetFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "Folder selection canceled. Exiting."
            Exit Sub
        End If
    End With
    
    ' Read S5 data into array and build match dictionary
    Set matchDict = CreateObject("Scripting.Dictionary")
    With filterWB.Sheets("S5")
        lastRowS5 = .Cells(.Rows.Count, "C").End(xlUp).Row
        s5Data = .Range("A1:C" & lastRowS5).Value ' Adjust columns if needed
        For i = 2 To lastRowS5 ' Skip header row if exists
            If Not matchDict.Exists(s5Data(i, 3)) Then
                matchDict(s5Data(i, 3)) = s5Data(i, 1) ' Key: C column value, Item: A column value
            End If
        Next i
    End With
    
    ' Optimize Excel settings for speed
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' Loop through all Excel files in target folder
    fileName = Dir(targetFolder & "*.xls*")
    Do While fileName <> ""
        ' Skip the filter workbook itself
        If targetFolder & fileName <> filterWB.FullName Then
            Set sourceWB = Workbooks.Open(targetFolder & fileName, ReadOnly:=True)
            Set sourceWS = sourceWB.Sheets("S1")
            
            With sourceWS
                lastRowS1 = .Cells(.Rows.Count, "AG").End(xlUp).Row
                s1Data = .Range("A1:AG" & lastRowS1).Value ' Adjust range to include all columns you need
                For i = 2 To lastRowS1 ' Skip header row
                    If matchDict.Exists(s1Data(i, 33)) Then ' AG is column 33 (A=1, AG=33)
                        ' Write S5 A column value first
                        summaryWS.Cells(summaryRow, "A").Value = matchDict(s1Data(i, 33))
                        ' Write all S1 row data starting from column B
                        summaryWS.Cells(summaryRow, "B").Resize(1, UBound(s1Data, 2)).Value = _
                            Application.Index(s1Data, i, 0)
                        summaryRow = summaryRow + 1
                    End If
                Next i
            End With
            
            sourceWB.Close SaveChanges:=False
        End If
        fileName = Dir()
    Loop
    
    ' Restore Excel settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "Bulk matching completed! Summary saved to 'Summary' sheet.", vbInformation
End Sub

Step 2: Key Optimizations Explained #

• Dictionary for Fast Lookups: Instead of searching through S5 every time, we store all match values in a Scripting.Dictionary—this turns slow O(n) lookups into instant O(1) checks, which is critical for handling big datasets.
• Array-Based Processing: Reading entire worksheet ranges into arrays cuts down on slow worksheet I/O operations, which is the biggest performance bottleneck for large files.
• Batch Writing: We write matched rows to the summary sheet efficiently, avoiding the lag of updating the sheet one cell at a time.
• Excel Speed Tweaks: Disabling screen updating, automatic calculation, and events prevents Excel from wasting resources on unnecessary updates during the loop.

Step 3: Important Notes #

1. Adjust Ranges: Modify the range references (like A1:C for S5, A1:AG for S1) to include all columns you need to copy from S1.
2. Headers: If your S5 and S1 sheets have headers, the code skips row 1 (starts at i=2)—adjust this if your data starts at row 1.
3. Data Type Consistency: Ensure that the values in S5 column C and S1 column AG are the same data type (e.g., both text or both numbers) to avoid mismatches.
4. ReadOnly Mode: The code opens source files in read-only mode to prevent accidental edits to your original data.

Just run this macro once, select your target folder, and let it do all the work—no more 56 manual runs!

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