How to expand the criteria of this macro to look for 2 string values?

Question

Looking for a bit of help.

Below in the code line: .Range("A1").CurrentRegion.AutoFilter field:=12, Criteria1:="In Progress" if I wanted to change it so the criteria it looks for is "In Progress" OR "Sale" , can someone advise on the syntax?

I cannot figure this out. If the field equals "In Progress" or "Sale" then the rest of the code works exactly as I need. It currently only takes "In Progress".

  Sub Garage()

Dim rData As Range

Application.ScreenUpdating = False

With Worksheets("CurrentList")
    .AutoFilterMode = False
    .Range("A1").CurrentRegion.AutoFilter field:=12, Criteria1:="In Progress"
    With .AutoFilter.Range
        On Error Resume Next
        Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rData Is Nothing Then
            Intersect(rData, .Range("A:U")).Copy Worksheets("Garages").Range("A" & Rows.Count).End(xlUp)(2)
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

`Criteria1:="In Progress", Operator:=xlOr, Criteria2:="Sale"`, or see the linked duplicate. — BigBen, Dec 01 '20 at 20:24

score 0 · Answer 1 · answered Dec 01 '20 at 20:53

Check this out:

Option Explicit
Option Base 1 'all array will start at 1
Dim shCurrentList As Worksheet, shGarages As Worksheet
Dim Criteria1$, Criteria2$
Dim rng As Range
Dim arr(), arrFilter()
Dim i%, j%, k%

Sub TestFilter()
    Set shCurrentList = Worksheets("CurrentList")
    Set shGarages = Worksheets("Garages")
    With shCurrentList
        Set rng = .Cells(1, 1).CurrentRegion
    End With
    arr = rng 'make an array with the range
    ReDim arrFilter(1 To UBound(arr), 1 To UBound(Application.Transpose(arr))) 'set a new array with the size of the original array
    Criteria1 = "In Progress": Criteria2 = "Sale"
    k = 1 'k is the first row of the second array
    For i = LBound(arr) + 1 To UBound(arr)
        If arr(i, 12) = Criteria1 Or arr(i, 12) = Criteria2 Then 'the value in row i, column 12 isequal to criteria1 or is equal to criteria2 then add it to the new array
            For j = 1 To UBound(arr) 'copy all the values to the new filtered array
                arrFilter(k, j) = arr(i, j)
            Next j
            k = k + 1
        End If
    Next i
    Debug.Print k
    'resize the filtered array to as many rows matched the criteria
    arrFilter = Application.Transpose(arrFilter) 'only last dimension of the array can be "redimed" so, first of all, transpose
    ReDim Preserve arrFilter(1 To UBound(arrFilter), 1 To k) 'resize it. Preserve means that you keep the values
    arrFilter = Application.Transpose(arrFilter) 'transpose again the array to have rows x columns in a right place
    Debug.Print k, UBound(arrFilter)
    With shGarages 'using with... end with is helpful, so you don't need to .select it to copy the values
        .Range(.Cells(2, 1), .Cells(UBound(arrFilter), UBound(arr))) = arrFilter 'starting at row 2, so header is not copied
    End With
    
End Sub

How to expand the criteria of this macro to look for 2 string values?

1 Answers1