Matching Multiple Criteria and Returning Multiple Values

Question

I have two spreadsheets ( wb and wbtemp ); both have a column for location and a column for feature type. In VBA, I want to find all of the rows on the second sheet where the two columns are the same as the two columns on a row in the first sheet and get a list or a range made up of the row numbers/indices.

I then want to use this range to pull out values from a different column and find the highest object in it, but I think I will probably be able to do that if I can get this range sorted.

Dim wb As Workbook
Dim ws As Worksheet
Dim Features() As Variant
Dim Activity() As Variant
Dim Benthic As Variant
Dim wbtemp As Workbook
Dim BenSenFeatures() As Variant
Dim BenSenActivity() As Variant
Dim LR As Long
Dim LC As Long
Dim r As Long
Dim c As Long
Dim WhatToFind1 As Variant
Dim WhatToFind2 As Variant
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim rng1 As Variant
Dim rng2 As Variant
Dim rngFound As Range
Dim iLoop As Long
Dim colFound As Range

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

Features = ws.Range("B:C").Value
Activity = ws.Rows(1).Value

Benthic = InputBox("Filename goes here...")
Set wbtemp = Workbooks.Open(Benthic, True, True)

With wbtemp
    BenSenFeatures = .Sheets(1).Range("A:B").Value
    BenSenActivity = .Sheets(1).Rows(1).Value
End With

LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For r = 3 To LR

    If Not IsEmpty(Features(r, 2)) Then
        If IsInArray(Features(r, 2), BenSenFeatures, 2) Then
        'If WorksheetFunction.Match(Features(r, 2), BenSenFeatures(0, 2), 0) Then   <---I tried to use the arrays originally
            WhatToFind1 = Features(r, 1)
            WhatToFind2 = Features(r, 2)
            Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells(wbtemp.Sheets(1).Columns(1).Cells.Count)
            Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells(wbtemp.Sheets(1).Columns(2).Cells.Count)
            For iLoop = 1 To WorksheetFunction.CountIf(wbtemp.Sheets(1).Columns(1), WhatToFind1)
                Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells.Find(WhatToFind1, After:=rngFound1)
                rng1(iLoop) = rngFound1.Row
            'WorksheetFunction.Index(wbtemp.Sheets(1).Range("A:B").Value,_
               WorksheetFunction.Match(WhatToFind1 & WhatToFind2,_
               wbtemp.Sheets(1).Columns(1) & wbtemp.Sheets(1).Columns(2),_
               0), 1)     <---originally tried to use match to search for the multiple criteria but couldn't find a way to create a list of indices
                Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells.Find(WhatToFind2, After:=rngFound2)
                rng2(iLoop) = rngFound2.Row
            Next iLoop
            For Each cell In rng1
                If Not Application.CountIf(rng2, cell.Value) = 0 Then
                    rngFound.Cells(Cells(Rows.Count, 1).End(xlUp) + 1) = cell.Value
                End If
            Next

I originally tried to use .Match to find the multiple criteria, but I couldn't figure out how to create a range of indices from it. Then I tried using .Find to create two list of indices but I can't figure out how to get that to work. I keep getting

Type Mismatch

errors.

I realise this sounds confusing, so let me know if anything needs clarifying.

Answer 1

Something like this should work for you. I tried to comment the code for clarity.

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rData As Range
    Dim wbTemp As Workbook
    Dim wsTemp As Worksheet
    Dim rTempData As Range
    Dim aData() As Variant
    Dim aTempData() As Variant
    Dim aResults() As Variant
    Dim lNumResults As Long
    Dim DataIndex As Long, TempIndex As Long, ResultIndex As Long, j As Long
    Dim sCritRange1 As String, sCritRange2 As String
    Dim sCriteria1 As String, sCriteria2 As String

    Set wb = ActiveWorkbook

    'Adjust these two as necessary
    Set ws = wb.Sheets(1)
    Set rData = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp))

    'Select wbTemp file
    On Error Resume Next
    Set wbTemp = Workbooks.Open(Application.GetOpenFilename("Excel Files, *.xls*"))
    On Error GoTo 0
    If wbTemp Is Nothing Then Exit Sub  'Pressed cancel

    'Adjust these two as necessary
    Set wsTemp = wbTemp.Sheets(1)
    Set rTempData = wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))

    sCritRange1 = rTempData.EntireColumn.Address(external:=True)
    sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
    sCriteria1 = rData.Address(external:=True)
    sCriteria2 = rData.Offset(, 1).Address(external:=True)
    lNumResults = Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")
    If lNumResults = 0 Then Exit Sub    'No matches
    ReDim aResults(1 To lNumResults, 1 To 3)
    aData = rData.Resize(, 2).Value
    aTempData = rTempData.Resize(, 2).Value

    'Loop through both data ranges
    For DataIndex = LBound(aData, 1) To UBound(aData, 1)
        For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)

            'Find where both criteria matches
            If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
                'Match found, add to results and collect the row index
                ResultIndex = ResultIndex + 1
                aResults(ResultIndex, 1) = aData(DataIndex, 1)
                aResults(ResultIndex, 2) = aData(DataIndex, 2)
                aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1   'This is the row index from wsTemp of the found match
            End If

        Next TempIndex
    Next DataIndex

    'Row index results gathered
    'Do what you want with the results
    'In this example it is just providing msgboxes displaying the results
    For ResultIndex = LBound(aResults, 1) To UBound(aResults, 1)
        MsgBox "Location: " & aResults(ResultIndex, 1) & Chr(10) & _
               "Feature:  " & aResults(ResultIndex, 2) & Chr(10) & _
               "RowIndex: " & aResults(ResultIndex, 3)
    Next ResultIndex

    'Close wbTemp
    wbTemp.Close

End Sub

Answer 2

I made some minor modifications to tigeravatar's answer to get it to work with my data:

• Mainly creating a loop which cycled through each row in wb so that the criteria used with CountIfs was a single value and not a range of values.
• I swapped the Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))") for Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)

I would like to thank tigeravatar for their help.

LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column   

For r = 3 To LR

sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData(r, 1).Address(external:=True)
sCriteria2 = rData(r, 1).Offset(, 1).Address(external:=True)
lNumResults = Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
If lNumResults = 0 Then Exit Sub    'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData(r, 1).Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value

'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
    For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)

        'Find where both criteria matches
        If Not IsEmpty(aTempData(TempIndex, 1)) Then
            If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
                'Match found, add to results and collect the row index
                ResultIndex = ResultIndex + 1
                aResults(ResultIndex, 1) = aData(DataIndex, 1)
                aResults(ResultIndex, 2) = aData(DataIndex, 2)
                aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1   'This is the row index from wsTemp of the found match
            End If
        End If

    Next TempIndex
Next DataIndex



Next r