Loop through Rows with multiple IF ANDs with an array as values

user_11989241 0
Viewed 120

I have an worksheet that has 3 columns A-C of text.

I want to write a VBA script to loop through each row and if (in each row) col a = (text 1 or text 2) AND col b = (Text5 or text 6 or text 7 or text 8) AND col c = (Text20 or Text 22) put a yes in column D

I was thinking of putting my text values to search for in multiple arrays:

Dim Search1 As Variant
Dim Search2 as Variant
Dim Search3 as Variant

Search1 = Array("Cat", "Dog")
Search2 = Array("Red", "Brown", "Blue")
Search2 = Array("House", "Condo")

Then do a loop through the rows:

Dim i As Long For i = 1 To rg.Rows.Count

Where I'm stuck is the search logic:

Application.CountIFs(Cells(i,1),Search1, Cells(i,2), Search2, Cells(i,3), Search4)) > 0 then
sh.Cells(i, "F").Value = "yes"
i = i + 1
End if
Next i

So something like:

A    B       C      D       
Dog    Brown House  Y       A=(Dog or Cat) AND  B=(Brown or Blue or Red)  AND C =( House or Condo)
Bird   Blue  House          
Cat    Brown Condo  Y       
Cat    Pink  Condo          
Cat    Blue  House  Y       
Horse  Red   Condo          
Cat    Green House          
Dog    Pink  Condo          
Horse  Blue  House

I hope this make sense...I'm really looking for how to do the countIF(Range, Array, Range,Array, Rang, Array) for each row.

Thank you!

countif vba excel arrays
1 Answers

Triple Match

Option Explicit

Sub TripleMatch()

    ' Define constants.
    Const SheetName As String = "Sheet1"
    Const Cols As String = "A:C"
    Const FirstRow As Long = 2
    Const TargetColumn As Long = 4
    Const StringValue As String = "Yes"
    Dim Search(2) As Variant
    Search(0) = Array("Cat", "Dog")
    Search(1) = Array("Red", "Brown", "Blue")
    Search(2) = Array("House", "Condo")

    ' Write values of Source Range to Source Array.
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(SheetName)
    Dim FirstColumn As Long
    FirstColumn = ws.Columns(Cols).Column
    Dim rng As Range
    Set rng = ws.Columns(FirstColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRow Then Exit Sub
    Dim Source As Variant
    Source = Intersect(ws.Range(ws.Cells(FirstRow, FirstColumn), rng) _
      .EntireRow.Rows, ws.Columns(Cols))

    ' Check Source Array and write to Target Array.
    Dim Target As Variant
    ReDim Target(1 To UBound(Source), 1 To 1)
    Dim i As Long, j As Long
    For i = 1 To UBound(Source)
        GoSub CheckValue
    Next i

    ' Write values of Target Array to Target Range.
    ws.Cells(FirstRow, TargetColumn).Resize(UBound(Target)).Value = Target

    ' Inform user.
    MsgBox "TripleMatch finished successfully.", vbInformation, "Success"

    Exit Sub

CheckValue:
    For j = 1 To UBound(Source, 2)
        If IsError(Application.Match(Source(i, j), Search(j - 1), 0)) Then
            Return
        End If
    Next j
    Target(i, 1) = StringValue
    Return

End Sub
user_98140690
Related