Autofilter with multiple criteria

[edwin23]

Hi,

I was wondering if there was a simpler way to delete rows based on multiple autofilter criteria.

My code now is as follows (I have individual lines for each criteria).

Is it possible to lump all criteria together, or to have it search within a range?

With ActiveSheet

             If .AutoFilterMode = False Then .Cells(1, 1).AutoFilter

                     .Range("A1").AutoFilter Field:=1, Criteria1:="15564"

                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    
                     .Range("A1").AutoFilter Field:=1, Criteria1:="10805"
                    
                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

                    .Range("A1").AutoFilter Field:=1, Criteria1:="16338"

                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete


                    .Range("A1").AutoFilter Field:=1, Criteria1:="14982"
                    
                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

                    .Range("A1").AutoFilter Field:=1, Criteria1:="16391"

                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete


                    .Range("A1").AutoFilter Field:=1, Criteria1:="14928"
                    
                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

                    .Range("A1").AutoFilter Field:=1, Criteria1:="15563"

                    .Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete


            .AutoFilterMode = False

    End With

 

[Domenic]

If you're using Excel 2007 or later, try...

[font=Verdana]    [color=darkblue]Dim[/color] Arr [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    
    Arr = Array("15564", "10805") [COLOR="Green"]'Add your other criteria[/COLOR]

    [color=darkblue]With[/color] ActiveSheet.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:=Arr, Operator:=xlFilterValues
        .Offset(1, 0).EntireRow.Delete
        .AutoFilter
    [color=darkblue]End[/color] [color=darkblue]With[/color][/font]

Otherwise, try...

[font=Verdana]    [color=darkblue]Dim[/color] Arr [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    Arr = Array("15564", "10805") [COLOR="Green"]'Add your other criteria[/COLOR]

    [color=darkblue]With[/color] ActiveSheet.Range("A1").CurrentRegion
        [color=darkblue]For[/color] i = [color=darkblue]LBound[/color](Arr) [color=darkblue]To[/color] [color=darkblue]UBound[/color](Arr)
            .AutoFilter field:=1, Criteria1:=Arr(i)
            .Offset(1, 0).EntireRow.Delete
        [color=darkblue]Next[/color] i
        .AutoFilter
    [color=darkblue]End[/color] [color=darkblue]With[/color][/font]

Alternatively, use the Advanced Filter.

 

[Dharmesh Patel]

Hi,
is this possible to do in a 2d array. So we can use the 1D array (Arr) to filter a 2d array (ArrMy2DArray) instead of using ActiveSheet.Range("A1").CurrentRegion.

Kind regards
D

 

[Domenic]

Hi,
is this possible to do in a 2d array. So we can use the 1D array (Arr) to filter a 2d array (ArrMy2DArray) instead of using ActiveSheet.Range("A1").CurrentRegion.

Kind regards
D

Assuming that you've already declared and defined 'ArrMy2DArray', the following code will filter the 2D array based on the first column, load the filtered data into a new 2D array called 'ArrMyNew2DArray', and then will write the data from this new array to Sheet2, starting at A1...

[font=Verdana]    [color=darkblue]Dim[/color] ArrMyNew2DArray() [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] Arr [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] Cnt [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] j [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    Arr = Array(15564, 10805) [color=green]'Add your other criteria[/color]
    
    [color=darkblue]For[/color] i = [color=darkblue]LBound[/color](ArrMy2DArray, 1) [color=darkblue]To[/color] [color=darkblue]UBound[/color](ArrMy2DArray, 1)
        MatchVal = Application.Match(ArrMy2DArray(i, 1), Arr, 0)
        [color=darkblue]If[/color] [color=darkblue]Not[/color] IsError(MatchVal) [color=darkblue]Then[/color]
            Cnt = Cnt + 1
            [color=darkblue]ReDim[/color] [color=darkblue]Preserve[/color] ArrMyNew2DArray(1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](ArrMy2DArray, 2), 1 [color=darkblue]To[/color] Cnt)
            [color=darkblue]For[/color] j = [color=darkblue]LBound[/color](ArrMy2DArray, 2) [color=darkblue]To[/color] [color=darkblue]UBound[/color](ArrMy2DArray, 2)
                ArrMyNew2DArray(j, Cnt) = ArrMy2DArray(i, j)
            [color=darkblue]Next[/color] j
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] i
    
    Worksheets("Sheet2").Range("A1").Resize(UBound(ArrMyNew2DArray, 2), UBound(ArrMyNew2DArray, 1)) = WorksheetFunction.Transpose(ArrMyNew2DArray)
    [/font]

 

[Dharmesh Patel]

Thankyou.

I used it to do multiple filters in 2d array.

   Sub test()
   
    Dim ArrMyNew2DArray() As Variant
    Dim Arr As Variant
     Dim Arr2 As Variant
    Dim Cnt As Long
    Dim i As Long
    Dim j As Long
    Dim ArrMy2DArray() As Variant
    Dim WS As Variant
    Dim Avalib As Variant
    Dim ArrMy2NDNew2DArray() As Variant
    
    ArrMy2DArray = Worksheets("Sheet1").Range("a1:g75").Value
    
    Avalib = Sheets("Sheet2").Range("B1")
    WS = Sheets("Sheet2").Range("A1")
    Arr = Array(WS)

    For i = LBound(ArrMy2DArray, 1) To UBound(ArrMy2DArray, 1)
    
    
        MatchVal = Application.Match(ArrMy2DArray(i, 1), Arr, 0)
        
        
        
        If Not IsError(MatchVal) Then
            Cnt = Cnt + 1
            ReDim Preserve ArrMyNew2DArray(1 To UBound(ArrMy2DArray, 2), 1 To Cnt)
            For j = LBound(ArrMy2DArray, 2) To UBound(ArrMy2DArray, 2)
                ArrMyNew2DArray(j, Cnt) = ArrMy2DArray(i, j)
            Next j
        End If
    Next i
    
    Worksheets("Sheet3").Range("A1").Resize(UBound(ArrMyNew2DArray, 2), UBound(ArrMyNew2DArray, 1)) = WorksheetFunction.Transpose(ArrMyNew2DArray)
ArrMyNew2DArray = Application.Transpose(ArrMyNew2DArray)

    i = 0
    j = 0
    Cnt = 0
     Arr2 = Array(Format(Avalib, "mmm-yy"))
    For i = LBound(ArrMyNew2DArray, 1) To UBound(ArrMyNew2DArray, 1)
        MatchVal = Application.Match(ArrMyNew2DArray(i, 7), Arr2, 0)
        If Not IsError(MatchVal) Then
            Cnt = Cnt + 1
            ReDim Preserve ArrMy2NDNew2DArray(1 To UBound(ArrMyNew2DArray, 2), 1 To Cnt)
            For j = LBound(ArrMyNew2DArray, 2) To UBound(ArrMyNew2DArray, 2)
                ArrMy2NDNew2DArray(j, Cnt) = ArrMyNew2DArray(i, j)
            Next j
        End If
    Next i
  Worksheets("Sheet4").Range("A1").Resize(UBound(ArrMy2NDNew2DArray, 2), UBound(ArrMy2NDNew2DArray, 1)) = WorksheetFunction.Transpose(ArrMy2NDNew2DArray)
End Sub

Application.Match is a string match, what would be the equivalent for grater then or less then.. Me being novice at vba I will try the long way around by referencing it to another array to filter all dates grater then the date in variable arr2.

Thanks again
D

 

[Domenic]

Try replacing...

MatchVal = Application.Match(ArrMy2DArray(i, 1), Arr, 0)

If Not IsError(MatchVal) Then
    .
    .
    .
    .
    .
End If

with

If ArrMy2DArray(i, 1) > Availib Then
    .
    .
    .
    .
    .
End If