excel - 基于多个条件的 VBA 过滤

Question

我有一个 Excel 工作簿，其中用户从工作表“报告生成器”的单元格 C4:C7 的下拉列表中输入最多四个关键字，然后我的 VBA 代码采用这些关键字，在另一个名为“数据”的工作表上进行过滤，复制过滤的行并将它们作为报告粘贴到 Word 文件中。该代码最多同时适用于两个关键字，但由于某种原因，当有三个或四个关键字时会失败，我不明白为什么。具体来说，当具有三个或四个关键字时，过滤返回 0 行，因此没有任何内容可复制。如果我尝试在 Excel 中手动执行，这不是问题，因此这不是数据问题。

下面是执行过滤的代码部分。如您所见，if循环从最后一个开始依次检查每个关键字是否为空，并将填充的关键字应用于过滤。循环每次都成功完成，但由于某种原因，在 3 或 4 个关键字的情况下过滤命令返回 0 行。你能帮我理解为什么会这样吗？谢谢！

    'Filter data based on keywords selected
Sheets("Data").Select

'If user inputs 1 keyword
If IsEmpty(Sheets("Report generator").Range("C7")) = True And IsEmpty(Sheets("Report generator").Range("C6")) = True And IsEmpty(Sheets("Report generator").Range("C5")) = True Then

    ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
        Array("*" & Sheets("Report generator").Range("C4").Value & "*"), _
    Operator:=xlFilterValues

'If user inputs 2 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = True And IsEmpty(Sheets("Report generator").Range("C6")) = True Then

    ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
        Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
        "*" & Sheets("Report generator").Range("C5").Value & "*"), _
    Operator:=xlFilterValues

'If user inputs 3 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = True Then

    ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
        Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
        "*" & Sheets("Report generator").Range("C5").Value & "*", _
        "*" & Sheets("Report generator").Range("C6").Value & "*"), _
    Operator:=xlFilterValues

'If user inputs 4 keywords
ElseIf IsEmpty(Sheets("Report generator").Range("C7")) = False And IsEmpty(Sheets("Report generator").Range("C6")) = False And IsEmpty(Sheets("Report generator").Range("C5")) = False And IsEmpty(Sheets("Report generator").Range("C4")) = False Then

    ActiveSheet.Range("$A$1:$F$1").AutoFilter Field:=5, Criteria1:= _
        Array("*" & Sheets("Report generator").Range("C4").Value & "*", _
        "*" & Sheets("Report generator").Range("C5").Value & "*", _
        "*" & Sheets("Report generator").Range("C6").Value & "*", _
        "*" & Sheets("Report generator").Range("C7").Value & "*"), _
    Operator:=xlFilterValues

End If

标签： excelvbafiltering

Answer 1

复制过滤的数据

• 主要问题是您不能在数组中使用超过两个包含通配符的元素。Criteria1
• 下面会将过滤后的数据复制到第三个工作表 ( Report)。然后，您可以将其导出到Word.

Option Explicit

Sub CopyFilteredData()
    
    Const lName As String = "Report Generator"
    Const lrgAddress As String = "C4:C7"
    
    Const sName As String = "Data"
    Const sCols As String = "A:F"
    Const sfField As Long = 5
    
    Const dName As String = "Report"
    Const dFirst As String = "A1"
    
    Const doCopyHeaders As Boolean = True ' e.g. if dFirst = "A2" then 'False'
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the criterias to a dictionary.
    
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lrg As Range: Set lrg = lws.Range(lrgAddress)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim lCell As Range
    Dim lString As String
    
    For Each lCell In lrg.Cells
        lString = CStr(lCell.Value)
        If Len(lString) > 0 Then
            dict("*" & lString & "*") = Empty
        End If
    Next lCell
    
    Dim dCount As Long: dCount = dict.Count
    If dCount = 0 Then Exit Sub ' no criterias
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then
        sws.AutoFilterMode = False
    End If
    
    ' Source Table Range
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion.Columns(sCols)
    ' Source Data Range ('strg' without headers)
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    Dim srg As Range
    
    Select Case dCount
    
    Case Is < 3 ' up to two criteria with wild characters
        
        strg.AutoFilter sfField, dict.Keys, xlFilterValues
        Set srg = sdrg.SpecialCells(xlCellTypeVisible)
        sws.AutoFilterMode = False
        
    Case Else ' more criteria with wild characters
        
        Dim fpCount As Long: fpCount = Int(dCount / 2)
        Dim UB As Long: UB = 1
        Dim arr As Variant: ReDim arr(0 To 1)
        
        Dim sfdrg As Range
        Dim fp As Long
        Dim n As Long
        
        ' For each filter pair...
        For fp = 0 To fpCount
            If fp = fpCount Then ' last loop only
                If dCount Mod 2 = 1 Then ' count is odd: needs to loop once more
                    UB = 0
                    ReDim arr(0 To 0)
                Else ' count is even: no need to loop anymore
                    UB = -1
                End If
            End If
            If UB > -1 Then
                ' Write criteria pair to an array.
                For n = 0 To UB
                    arr(n) = dict.Keys()(n + fp * 2)
                Next n
                ' Filter Source Data Range.
                sdrg.AutoFilter sfField, arr, xlFilterValues
                ' Combine filtered range into Source Range.
                On Error Resume Next
                Set sfdrg = sdrg.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                sws.AutoFilterMode = False
                If Not sfdrg Is Nothing Then
                    If srg Is Nothing Then
                        Set srg = sfdrg
                    Else
                        Set srg = Union(srg, sfdrg)
                    End If
                    Set sfdrg = Nothing
                End If
            End If
        Next fp
        
    End Select
    
    If srg Is Nothing Then Exit Sub
    
    If doCopyHeaders Then
        Set srg = Union(strg.Rows(1), srg)
    End If
    Debug.Print srg.Address(0, 0)
    
    ' Copy to the Destination worksheet.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    dws.Cells.Clear
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    srg.Copy dfCell
    
End Sub