Home Matching Multiple Criteria and Returning Multiple Values

# Matching Multiple Criteria and Returning Multiple Values

S.Chivers
1#
S.Chivers Published in 2018-02-14 18:11:37Z
 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.
tigeravatar
2#
 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 
 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