请求优化Excel多True/False条件查询的VBA代码

问题背景 #

我是VBA新手，现有一个查询公司数据库的宏，但要适配100+True/False查询条件时，代码冗余得离谱。涉及两个工作表：

• CompDB：存储公司信息及对应的True/False属性
• QueryDB：存储查询条件和查询结果

预期执行流程 #

• 若所有查询条件为False，复制整个CompDB到结果区
• 若存在True条件，复制符合任一True条件的公司数据
• 最终结果按公司名排序、去重

当前卡壳点 #

1. 没法高效判断所有条件是否全为False，现在是硬编码一堆And判断
2. 没法高效循环处理True条件，每个条件都要写一段重复的AutoFilter代码
3. 试过高级筛选，但它只会返回符合所有True条件的公司，不符合“任一”的需求

现有冗余代码 #

Option Explicit
    Dim LastRow As Long, LastCompRow As Long
    
Sub Query() 'Run query
Application.ScreenUpdating = False
  
LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1

LastCompRow = ThisWorkbook.Worksheets("CompDB").Range("A99999").End(xlUp).Row
    
    With QueryDB
    
        '判断所有条件是否全为False，是则复制整个数据库
        If .Range("D3").Value = False And .Range("E3").Value = False And .Range("F3").Value = False And .Range("G3").Value = False And .Range("H3").Value = False And .Range("I3").Value = False And .Range("J3").Value = False And .Range("K3").Value = False Then
                CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
            Exit Sub
        End If
        
        '逐个处理True条件，复制符合条件的数据
        If .Range("D3").Value = True Then
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=4, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
        
        If .Range("E3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=5, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
        
        If .Range("F3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=6, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
        
        If .Range("G3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=7, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
        
        If .Range("H3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=8, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
        
        If .Range("I3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=9, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If

        If .Range("J3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=10, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If

        If .Range("K3").Value = True Then
            LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row + 1
            CompDB.Range("A1:K" & LastCompRow).AutoFilter Field:=11, Criteria1:="True"
            CompDB.Range("A2:K" & LastCompRow).Copy Destination:=.Range("A" & LastRow)
        With CompDB
            .AutoFilterMode = False
        End With
        End If
    
    '去重处理
    LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row
    .Range("A14:K" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
    
    '按公司名排序
    LastRow = ThisWorkbook.Worksheets("QueryDB").Range("A99999").End(xlUp).Row
    .Range("A14:K" & LastRow).Sort Key1:=Range("B14"), Order1:=xlAscending, Header:=xlYes
    
    End With

Application.ScreenUpdating = True
End Sub

Sub ClearQueryResults() '清空之前的查询结果

    With QueryDB
        .Range("A15:K99999").ClearContents
    End With

End Sub

优化后的代码 #

Option Explicit
Dim wsComp As Worksheet, wsQuery As Worksheet
Dim lastCompRow As Long, lastQueryRow As Long
Dim criteriaRange As Range, criteriaCell As Range
Dim filterFields As Collection

Sub RunQuery()
    Application.ScreenUpdating = False
    
    ' 初始化工作表对象，减少重复引用
    Set wsComp = ThisWorkbook.Worksheets("CompDB")
    Set wsQuery = ThisWorkbook.Worksheets("QueryDB")
    ' 可根据实际条件列范围调整，比如100列就改成D3:CV3
    Set criteriaRange = wsQuery.Range("D3:K3")
    
    lastCompRow = wsComp.Cells(wsComp.Rows.Count, "A").End(xlUp).Row
    lastQueryRow = wsQuery.Cells(wsQuery.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 快速判断所有条件是否全为False
    If WorksheetFunction.CountIf(criteriaRange, True) = 0 Then
        wsComp.Range("A2:K" & lastCompRow).Copy Destination:=wsQuery.Range("A" & lastQueryRow)
        GoTo Finalize ' 直接跳转到排序去重环节
    End If
    
    ' 收集所有为True的条件对应的CompDB字段序号
    Set filterFields = New Collection
    For Each criteriaCell In criteriaRange
        If criteriaCell.Value = True Then
            ' QueryDB的条件列号直接对应CompDB的字段号（比如D列是第4列，对应CompDB第4字段）
            filterFields.Add criteriaCell.Column
        End If
    Next criteriaCell
    
    ' 应用多条件"或"筛选，一次搞定所有True条件
    With wsComp.Range("A1:K" & lastCompRow)
        .AutoFilter
        Dim i As Integer
        For i = 1 To filterFields.Count
            ' 第一个条件无需加Operator，后续条件用xlOr实现"或"逻辑
            If i = 1 Then
                .AutoFilter Field:=filterFields(i), Criteria1:=True
            Else
                .AutoFilter Field:=filterFields(i), Criteria1:=True, Operator:=xlOr
            End If
        Next i
        ' 复制筛选后的结果（跳过表头）
        .Offset(1).Resize(lastCompRow - 1).Copy Destination:=wsQuery.Range("A" & lastQueryRow)
        .AutoFilterMode = False ' 关闭筛选
    End With
    
Finalize:
    ' 统一处理去重和排序
    lastQueryRow = wsQuery.Cells(wsQuery.Rows.Count, "A").End(xlUp).Row
    With wsQuery.Range("A14:K" & lastQueryRow)
        .RemoveDuplicates Columns:=1, Header:=xlYes
        .Sort Key1:=wsQuery.Range("B14"), Order1:=xlAscending, Header:=xlYes
    End With
    
    Application.ScreenUpdating = True
End Sub

Sub ClearQueryResults()
    ' 优化清空逻辑，避免硬编码行号
    With ThisWorkbook.Worksheets("QueryDB")
        .Range("A15:K" & .Rows.Count).ClearContents
    End With
End Sub

优化说明 #

1. 高效判断全False：用CountIf统计条件范围内True的数量，等于0就说明全是False，不管有多少条件列都不用改代码
2. 循环处理条件：遍历条件范围自动收集True对应的字段，轻松适配100+条件，不用再写重复的If判断
3. 多条件"或"筛选：一次AutoFilter添加所有Or条件，避免多次复制粘贴，运行效率更高
4. 代码可维护性：只需调整criteriaRange的范围，就能适配不同数量的条件列，后续修改更方便

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