如何在数组中使用If过滤多列多条件vba

Question

我想知道我们是否可以在数组中使用" if“来过滤单个代码中的多个列。例如，我有两列数据&为了得到结果，我必须使用过滤器两次。

在第7列中使用Apple进行过滤的第一步&今天-第3列中的第3列和第8列中的之前

ActiveSheet.Range("A1:W100000").AutoFilter Field:=7, Operator:=xlFilterValues, Criteria1:="Apple"
ActiveSheet.Range("A1:W100000").AutoFilter Field:=8, Operator:=xlFilterValues, Criteria1:="=>"& Date-3)

在第7列中使用香蕉过滤的第二步-第8列中的今天-7和之前

ActiveSheet.Range("A1:W100000").AutoFilter Field:=7, Operator:=xlFilterValues, Criteria1:="Banana"
ActiveSheet.Range("A1:W100000").AutoFilter Field:=8, Operator:=xlFilterValues, Criteria1:="=>"& Date-7)

有没有可能通过使用"If“作为一个像"(If field 7= Apple，field 8= "=>"& Date-3)”和(If field 7= Banana，field 8= "=>"& Date-7)“这样的数组来一次性获得过滤结果？

请帮帮忙

Sub Get_Value()
    Sheets.ADD After:=Sheets(Sheets.count)
    ActiveSheet.Name = "Sheet2"
    Worksheets("Sheet1").Select
    Worksheets("Sheet1").AutoFilterMode = False
    Application.DisplayAlerts = False
    ActiveSheet.Range("A1:AZ100000").AutoFilter Field:=7, Criteria1:="Apple"
    ActiveSheet.Range("A1:AZ100000").AutoFilter Field:=8, Criteria1:="<=" & Date - 3
If (ActiveSheet.Range("G2", Range("G" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible).count - 1) = 0 Then
    MsgBox "There are no values found"
    Else
    Worksheets("Sheet1").Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Worksheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
End If
    Worksheets("Sheet1").Select
    Worksheets("Sheet1").AutoFilterMode = False
    Application.DisplayAlerts = False
    ActiveSheet.Range("A1:AZ100000").AutoFilter Field:=7, Criteria1:="Banana"
    ActiveSheet.Range("A1:AZ100000").AutoFilter Field:=8, Criteria1:="<=" & Date - 7
If (ActiveSheet.Range("G2", Range("G" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible).count - 1) = 0 Then
    MsgBox "There are no values found"
    Else
    ActiveSheet.Range("G2", Range("G" & Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
    Worksheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
End If

结束子对象

Answer 1

考虑为您的逻辑需求创建一个新列，并在该条件下应用过滤器。避免使用Select和ActiveSheet，并使用所有Excel sheet和range对象的完整句点限定符。此外，下面仅显示了特定的过滤器解决方案，而不显示应相应集成的其他新工作表或复制/粘贴步骤。

Dim i As Long

With ThisWorkbook.Worksheets("Sheet1")
    .AutoFilterMode = False
     Application.DisplayAlerts = False

    ' ADD CONDITIONAL COLUMN (G AS 7th COLUMN, H AS 8TH COLUMN)
    For i = 2 To 100000
       .Range("BA" & i).Formula = "=IF(OR(AND(G" & i & " = ""Apple"",  H" & i & " <= DATEVALUE(""" & Date - 3 & """))," _
                                      & " AND(G" & i & " = ""Banana"", H" & i & " <= DATEVALUE(""" & Date - 7 & """))), TRUE, FALSE)"
    Next i
    
    ' ALTERNATIVE PER @VBasic2008
    ' .Range("BA2:BA" & 20).Formula = "=IF(OR(AND(G2 = ""Apple"",  H2 <= TODAY() - 3)," _
    '                                     & " AND(G2 = ""Banana"", H2 <= TODAY() - 7)), TRUE, FALSE)"

    ' APPLY FILTER (BA BEING 53RD COLUMN)
    .Range("A1:BA1").AutoFilter Field:=53, Criteria1:="TRUE"
End With

Answer 2

复制多过滤(Advanced Filter)

Option Explicit

Sub copyMultiFiltered()
    
    Const sName As String = "Sheet1"
    Const dName As String = "Sheet2"
    
    Dim Fields As Variant: Fields = Array(7, 8)
    Dim CritPairs As Variant
    CritPairs = Array("Apple", 3, "Banana", 7)
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim fInit As Long: fInit = LBound(Fields) - 1
    Dim crInit As Long: crInit = LBound(CritPairs) - 1
    Dim rCount As Long: rCount = (UBound(CritPairs) - crInit) / 2 + 1
    Dim Data As Variant: ReDim Data(1 To rCount, 1 To 2)
    
    Dim srg As Range: Set srg = wb.Worksheets(sName).Range("A1").CurrentRegion
    
    Dim j As Long
    For j = 1 To 2
        Data(1, j) = srg.Cells(1, Fields(fInit + j)).Value
    Next j
    For j = 2 To rCount
        Data(j, 1) = CritPairs((j - 2) * 2 + crInit + 1)
        Data(j, 2) = "<=" & CLng(Date - CritPairs((j - 2) * 2 + crInit + 2))
    Next j
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    On Error GoTo 0
    If dws Is Nothing Then
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = dName
    Else
        dws.Cells.Clear
    End If
    
    Dim crg As Range
    Dim drg As Range
    With dws.Range("A1")
        Set crg = .Resize(rCount, 2)
        crg.Value = Data
        Set drg = .Resize(, srg.Columns.Count).Offset(rCount + 1)
    End With
    
    srg.AdvancedFilter xlFilterCopy, crg, drg
    
    dws.Rows(1).Resize(rCount + 1).Delete
    srg.Rows(1).Copy
    With dws.Cells(1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        Application.CutCopyMode = False
        .Worksheet.Activate
        .Select
    End With
    
    Application.ScreenUpdating = True

End Sub