如何修改VBA代码实现双条件筛选并复制数据至新工作表

需求背景 #

此前使用@VBasic2008提供的单条件筛选（D列唯一值）VBA代码运行正常，现需调整为双条件筛选逻辑：

• 先筛选A列指定公司代码（示例值：UK1）
• 基于该结果，循环筛选D列的唯一值
• 将每个筛选结果（包含表头）复制到新工作表，原数据范围限定为A-Z列

修改后的VBA代码 #

Sub CreateDualConditionSummary()
    
    ' 定义常量
    ' 数据源设置
    Const SOURCE_NAME As String = "Sheet1"
    Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
    Const COMPANY_COLUMN_INDEX As Long = 1 ' A列：公司代码列
    Const TARGET_COMPANY As String = "UK1" ' 指定要筛选的公司代码
    Const UNIQUE_COLUMN_INDEX As Long = 4 ' D列：要循环的唯一值列
    ' 目标工作表设置
    Const DESTINATION_NAME As String = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    Const DESTINATION_GAP As Long = 1 ' 结果之间的空行数量

    ' 引用当前工作簿
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' 引用数据源工作表并清除现有筛选
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
    If sws.FilterMode Then sws.ShowAllData
    
    ' 定义数据源范围（限定为A-Z列的当前数据区域）
    Dim srg As Range: Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
    Set srg = Intersect(srg, sws.Columns("A:Z"))
    
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount = 1 Then Exit Sub ' 仅表头或空表，直接退出
    
    Dim scCount As Long: scCount = srg.Columns.Count
    ' 检查列数是否满足筛选要求
    If scCount < COMPANY_COLUMN_INDEX Or scCount < UNIQUE_COLUMN_INDEX Then
        Exit Sub
    End If
    
    ' 先筛选指定公司代码，提取符合条件的D列唯一值
    srg.AutoFilter COMPANY_COLUMN_INDEX, TARGET_COMPANY
    ' 获取筛选后的D列数据（跳过表头）
    Dim filteredDValues As Variant
    On Error Resume Next ' 处理筛选后无数据的情况
    filteredDValues = sws.Range(srg.Columns(UNIQUE_COLUMN_INDEX).Offset(1), _
                                srg.Columns(UNIQUE_COLUMN_INDEX).End(xlDown)).Value
    On Error GoTo 0
    
    ' 用字典存储D列的唯一值及出现次数
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sString As String
    Dim sr As Long
    
    If IsArray(filteredDValues) Then ' 确保有数据才循环
        For sr = LBound(filteredDValues, 1) To UBound(filteredDValues, 1)
            sString = CStr(filteredDValues(sr, 1))
            If Len(sString) > 0 Then dict(sString) = dict(sString) + 1
        Next sr
    End If
    
    sws.ShowAllData ' 清除公司筛选，准备后续双条件筛选
    If dict.Count = 0 Then Exit Sub ' 无有效唯一值，退出
    Erase filteredDValues
    
    ' 准备目标工作表
    Application.ScreenUpdating = False
    
    Dim dsh As Object
    On Error Resume Next
        Set dsh = wb.Sheets(DESTINATION_NAME)
    On Error GoTo 0
    If Not dsh Is Nothing Then
        Application.DisplayAlerts = False
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=sws)
    dws.Name = DESTINATION_NAME
    Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' 复制表头列宽
    srg.Rows(1).Copy
    dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
    dCell.Select
    
    ' 循环双条件筛选并复制结果
    Dim sKey As Variant
    
    For Each sKey In dict.Keys
        ' 双条件筛选：A列公司代码 + D列唯一值
        srg.AutoFilter COMPANY_COLUMN_INDEX, TARGET_COMPANY
        srg.AutoFilter UNIQUE_COLUMN_INDEX, sKey
        ' 复制筛选结果到目标位置
        srg.Copy dCell
        sws.ShowAllData
        ' 计算下一个结果的起始位置（表头+数据行+空行）
        Set dCell = dCell.Offset(DESTINATION_GAP + dict(sKey) + 1)
    Next sKey
    
    sws.AutoFilterMode = False
    ' wb.Save ' 如需自动保存，可取消注释
    
    Application.ScreenUpdating = True
    
    ' 提示完成
    MsgBox "双条件筛选汇总已创建。", vbInformation
    
End Sub

核心修改点 #

1. 新增参数配置：添加公司代码列、目标公司代码的常量，方便后续快速修改筛选条件
2. 前置公司筛选：先筛选出指定公司的数据，再从中提取D列唯一值，确保后续循环的是符合公司要求的D列值
3. 双条件筛选实现：在循环中同时设置两个AutoFilter条件，保证每次复制的是双重筛选后的结果
4. 边界处理优化：增加了筛选后无数据的错误处理，避免代码报错
5. 数据范围限定：通过Intersect将数据源限制在A-Z列，避免超出需求范围

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