Excel VBA需求：遍历G列自动筛选条件并批量生成序列文件

需求与痛点 #

需要遍历G列的所有自动筛选条件，将每个条件筛选后的数据整理复制到模板文件，最终保存为递增序列命名的新文件。原代码硬编码单个筛选条件，采用If-Else逻辑导致代码冗长、扩展性差，需重构为循环实现。

优化后代码 #

Option Explicit

Sub BatchGenerateFilteredFiles()
    Dim wbSource As Workbook, wbTemplate As Workbook
    Dim wsSource As Worksheet, wsDest As Worksheet, wsTemplateDest As Worksheet
    Dim lastRow As Long, maxFileNum As Integer
    Dim sourceSheetName As String, templateSheetName As String
    Dim folderPath As String, templatePath As String, newFileName As String
    Dim filterCriteria As Variant, uniqueCriterias As Object
    Dim cell As Range
    
    ' 基础配置
    sourceSheetName = "2011-2019"
    templateSheetName = "Cable Collection Advices (2)"
    folderPath = "Q:\Alan\VBA\CCA\"
    templatePath = "\\SSSSNNMR20\EAS2EAS1\75 ABCDE Engineering\76 CABLE Engineering - General\PE-Test-ABCDE\E_P\02 AB\Alan\VBA\CCA\Cable Collection Advices - 11.xls"
    
    ' 初始化对象
    Set wbSource = ThisWorkbook
    Set wsSource = wbSource.Sheets(sourceSheetName)
    Set uniqueCriterias = CreateObject("Scripting.Dictionary")
    
    ' 关闭屏幕更新与警告，提升效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 清除现有筛选
    Call ClearAllFilters
    
    ' 提取G列（第7列）的唯一筛选条件
    lastRow = wsSource.Cells(wsSource.Rows.Count, 7).End(xlUp).Row
    For Each cell In wsSource.Range("G2:G" & lastRow) ' 跳过表头
        If Not uniqueCriterias.Exists(cell.Value) And cell.Value <> "" Then
            uniqueCriterias.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' 获取当前文件夹中最大文件编号
    maxFileNum = GetMaxFileNumber(folderPath)
    
    ' 循环遍历每个筛选条件
    For Each filterCriteria In uniqueCriterias.Keys
        ' 执行筛选
        wsSource.Range("A1:U1").AutoFilter Field:=7, Criteria1:=filterCriteria
        wsSource.Range("A1:U1").AutoFilter Field:=14, Criteria1:="Available", Operator:=xlOr, Criteria2:="="
        
        ' 检查是否有筛选结果
        On Error Resume Next
        Dim visibleRowsCount As Long
        visibleRowsCount = wsSource.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count
        On Error GoTo 0
        
        If visibleRowsCount > 1 Then ' 大于1表示除了表头还有数据
            ' 创建临时工作表存放筛选结果
            Set wsDest = wbSource.Sheets.Add(After:=wbSource.Sheets(wbSource.Sheets.Count))
            wsDest.Name = "Filtered Data"
            
            ' 复制筛选后的数据
            wsSource.Cells.SpecialCells(xlCellTypeVisible).Copy
            wsDest.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
            
            ' 整理数据（删除不需要的列和行）
            wsDest.Columns("N:U").Delete
            wsDest.Columns("A:B").Delete
            wsDest.Columns("F").Delete
            wsDest.Rows(1).Delete
            
            lastRow = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row
            
            ' 打开模板文件
            Set wbTemplate = Workbooks.Open(templatePath)
            Set wsTemplateDest = wbTemplate.Sheets(templateSheetName)
            
            ' 复制整理后的数据到模板
            wsDest.Range("A1:D" & lastRow).Copy
            wsTemplateDest.Range("C8").PasteSpecial xlPasteValues
            
            wsDest.Range("F1:G" & lastRow).Copy
            wsTemplateDest.Range("G8").PasteSpecial xlPasteValues
            
            wsDest.Range("E1:E" & lastRow).Copy
            wsTemplateDest.Range("I8").PasteSpecial xlPasteValues
            
            wsDest.Range("J1:J" & lastRow).Copy
            wsTemplateDest.Range("J8").PasteSpecial xlPasteValues
            
            ' 填充日期
            wsTemplateDest.Range("A8:A" & lastRow + 7).Value = Format(Now(), "dd.mm.yyyy")
            wsTemplateDest.Range("B5").Value = Format(Now(), "dd.mm.yyyy")
            
            ' 生成新文件名并保存
            maxFileNum = maxFileNum + 1
            newFileName = folderPath & "Cable Collection Advices - " & maxFileNum & ".xlsx"
            wbTemplate.SaveAs Filename:=newFileName, FileFormat:=51, CreateBackup:=False
            
            ' 关闭模板文件，删除临时工作表
            wbTemplate.Close SaveChanges:=False
            wsDest.Delete
        Else
            MsgBox "筛选条件 [" & filterCriteria & "] 无数据"
        End If
        
        ' 清除当前筛选，准备下一次循环
        Call ClearAllFilters
    Next filterCriteria
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "批量处理完成！"
End Sub

' 获取文件夹中最大的文件编号
Function GetMaxFileNumber(folderPath As String) As Integer
    Dim fileName As String, fileNum As Integer, maxNum As Integer
    maxNum = 1
    fileName = Dir(folderPath & "Cable Collection Advices - *.xlsx")
    
    Do While fileName <> ""
        fileNum = CInt(Mid(fileName, InStrRev(fileName, " - ") + 3, Len(fileName) - InStrRev(fileName, " - ") - 5))
        If fileNum > maxNum Then maxNum = fileNum
        fileName = Dir
    Loop
    
    GetMaxFileNumber = maxNum
End Function

' 清除所有工作表的筛选
Sub ClearAllFilters()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .AutoFilterMode Then
                If .FilterMode Then .ShowAllData
            End If
        End With
    Next ws
End Sub

关键改进说明 #

• 循环遍历筛选条件：使用字典提取G列唯一值，通过For Each循环自动处理所有条件，无需硬编码单个值
• 模块化拆分：将获取最大文件编号、清除筛选等逻辑拆分为独立函数/子过程，代码结构更清晰，易维护
• 效率优化：统一管理Excel环境设置（屏幕更新、警告），避免重复操作；直接通过对象引用操作工作表，减少Activate/Select的冗余调用
• 错误处理：添加可见行计数的错误捕获，防止无筛选数据时代码崩溃
• 扩展性提升：后续新增筛选条件无需修改核心逻辑，只需保证G列数据格式统一即可

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