VLookup with Multiple Criteria with VBA and the array formula method

A) VBA "VLookup" based on ListObject data

As you refer to a ListObject in OP, I focussed upon an approach based entirely on listobject data.

As a practical surplus it would be neat to identify column references by existing table headers or index numbers. So the function multCrit() below returns the value of a given column (retCol) with any number of column criteria.

"As a fancy I am looking for something like this foo = Match(1,(A1=rangeA)*(B1=rangeB)*(C1=rangeC),0), small and understanding."

Organizing inputs in a ParamArray might help at least to hold the function call small and clear, e.g. via the following pseudo syntax

multCrit(lo, ReturnColumn, ParamArray:{Col1, search1, Col2, search2,...})  

Note that I only reversed the input order within the ParamArray.

Needed Arguments

• 1st argument data identifies a ListObject,
• 2nd argument retCol identifies the column to be returned (header or index),
• 3rd 0-based argument ParamArray arr() allows multiple inputs in the following order:

       - even inputs identify column (by header string or index number)
       - odd  inputs define a search value (e.g. explicitly or as cell reference)

"There should be a built-in way to do it in VBA, I am guessing."

Methodically this approach tries to

• get column array blocks for each criteria (in one go via Application.Index() - note the use of two array arguments!)
• within a temporary array container tmp (aka as jagged array) and
• showing value 1 for findings (and #NV error 2042 for non-findings) in each criteria block.

This allows to identify value 1 sequences in all indicated column blocks, even if this approach doesn't dispose of a built-in check by multiplying boolean values as in Excel functions. - Of course there are still several opportunities for improvement (e.g. to find the next possible item instead of row-wise loops), but it shows the way.

Function multCrit()

Function multCrit(data As ListObject, ByVal retCol, ParamArray crit() As Variant) As Variant

'0) provide for 0-based temporary array container (aka jagged critay)
    Dim critCnt As Long: critCnt = (UBound(crit) + 1) \ 2
    Dim tmp: ReDim tmp(0 To critCnt - 1)
    
'1) include an array/column in one go into temporary array container
    Dim c As Long
    For c = LBound(crit) To UBound(crit) Step 2
        '~~~~~~~~~~~~~~~~~~~
        'execute 1 Match/col ~~> found elements receive value 1 (non-findings error 2042)
        '~~~~~~~~~~~~~~~~~~~
        tmp(c \ 2) = Application.Match(getCol(data, crit(c)), Array(crit(c + 1)), 0)
        'Debug.Print "tmp(" & c \ 2 & ")", "header: " & crit(c), data.ListColumns(crit(c)).Index, crit(c + 1)
    Next
    
'2) get lookup value as soon as all column values in a given row equal 1
    Dim r As Long
    For r = 1 To UBound(tmp(0))
        For c = 0 To UBound(tmp)
            'check next row, if no value 1 found
            If IsError(tmp(c)(r, 1)) Then Exit For  ' escape to check next row
            If c = UBound(tmp) Then                 ' struggled through to last element
                'get result value of found row from referenced retCol
                multCrit = getCol(data, retCol)(r, 1): Exit Function
            End If
        Next c
    Next r
End Function

Help function getCol()

Returns column data identified by header name or index number of the ListObject:

Function getCol(data As ListObject, header)
'Purp:  get listobject column data via header (either string or index number)
    getCol = data.DataBodyRange.Columns(data.ListColumns(header).Index)
End Function

Example Call

Note that the function allows any order of header (and search item) inputs, whether explicitly or as range reference; so this example demonstrates a modified column order and range inputs, too:

Sub ExampleCall()
    Dim lo As ListObject
    Set lo = Sheet1.ListObjects("Table1")
    'example display in VB Editor's immediate window: ~~> EN
    Debug.Print "*~~>", multCrit(lo, "lang", "Col2", "two", "Col3", "three", "Col1", Sheet1.Range("B1"))
End Sub

Possible code extension // edited 2021-12-12

If you don't insist to return a value (being typical for a VLookUp solution), but to return the found data row as further option, you might

• provide e.g. for passing a zero-input (0) to argument retCol and
• change the last code part of function MultCrit() as follows:

                'get result value of found row from referenced retCol
                If retCol = 0 Then                  ' special arg 0: return row
                    multCrit = r
                Else                                ' default: return value
                    multCrit = getCol(data, retCol)(r, 1): Exit Function
                End If

Then displaying via Debug.Print "*~~>", multCrit(lo, 0, "Col2", "two", "Col3", "three", "Col1", Sheet1.Range("B1")) would show e.g. the 2nd row as numeric result: ~~> 2.

B) Short alternative via XlRangeValueDataType enumeration in .Value(12) // ►late Edit as of 2021-12-13◄

This methodically new approach is based entirely on a string analysis of .Value(xlRangeValueMSPersistXML) - also known as .Value(12) -, which returns the recordset representation of the specified (ListObject) range as XML formatted string.

• A snippet example of a row node holding column info attributes Col1, Col2 etc could be:

<xml><!-- omitting all namespace definitions -->
  <!-- omitted ... -->
  <rs:data>
   <z:row Col1="DE" Col2="eins" Col3="zwei" Col4="drei"/>
   <!-- etc... -->
  </rs:data>
 </x:PivotCache>
</xml> 

Applying ► FilterXML on this (slightly transformed) content via an XPath search expression combining all criteria conditions programatically, like here e.g.

    "//zrow[@Col3='two' and @Col4='three' and @Col2='one']/@Col1"`

allows to return the indexed column value passed by argument retCol. *(Note that I transform the original content to allow an easier search without namespace issues, c.f. zrow instead of z:row)

This example can be called similar to ExampleCall in case A (but wouldn't return a row index as proposed in "Possible code extensions").

Function MultCrit12(lo As ListObject, ByVal retCol, ParamArray crit() As Variant) As Variant
'1) get FilterXML arguments
'   a) Arg1: wellformed xml content string (xlRangeValueMSPersistXML = 12)
    Dim content As String
    content = Replace(lo.Range.Value(12), ":", "")
    
'   b) Arg2: XPath by analyzing ParamArray crit()
    Dim c As Long
    Dim XPath As String: XPath = "//zrow["
    For c = LBound(crit) To UBound(crit) Step 2
        XPath = XPath & " and @Col" & lo.ListColumns(crit(c)).Index & "='" & crit(c + 1) & "'"
    Next
    If VarType(retCol) = vbString Then retCol = lo.ListColumns(retCol).Index   ' get column index of header
    XPath = Replace(XPath, "[ and ", "[") & "]/@Col" & retCol

'2) apply FilterXML upon above arguments
    With Application
        Dim ret
        ret = .FilterXML(content, XPath)   ' << FilterXML
        If VarType(ret) > vbArray Then
            MultCrit12 = ret(1, 1)
        Else
            MultCrit12 = ret
        End If
    End With
End Function

Do you want a way to lookup n number of criteria?

assuming the following data:

You could use XLOOKUP:

=XLOOKUP(1&1&1,A1:A9&B1:B9&C1:C9,D1:D9,"Not Found";)

This will find the last row where a,b, and c = 1 and result is 8

Moving to Select Case from Ifs would at least make things cleaner to add more criteria later (cleanliness is fanciness?); just add new cases, rather than messing with If and spacing, etc. My mock-up:

For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count
    Select Case False
        Case lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1)
        Case lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3)
        Case lo.ListColumns(myArray(4)).Range.Cells(RowIndex:=i) = myArray(5)
        Case Else 
            GetLookupDataTriple = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i)
            Exit For
    End Select
Next i

This definitely isn't down to your foo = Match(1,(A1=rangeA)*(B1=rangeB)*(C1=rangeC),0) level of fancy/clean, though.

How abut the following:

Sub Macro1()
'
' Macro1 Macro
'

'
Dim myArray(5) As Variant
myArray(0) = "a"
myArray(1) = 1
myArray(2) = "b"
myArray(3) = 1
myArray(4) = "c"
myArray(5) = 1

    MsgBox (GetLookupDataTriple2("Table1", "result", myArray))
End Sub


Function GetLookupDataTriple2(tableName As String, lookIntoColumn As String, myArray As Variant) As Variant
    
    Dim lo As ListObject
    Set lo = Sheet1.ListObjects(tableName)
    
    noOfSearchParam = UBound(myArray) - LBound(myArray)
    
    Dim found As Boolean
    
    For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count
     found = True
        For s = 0 To noOfSearchParam Step 2
            If lo.ListColumns(myArray(s)).Range.Cells(RowIndex:=i) <> myArray(s + 1) Then
                 found = False
            End If
        Next s
        If found Then
            GetLookupDataTriple2 = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i)
            Exit Function
        End If
    Next i
    GetLookupDataTriple2 = -1
End Function

the worksheet will allow the multiplication/addition of arrays, but vba does not. That is the root of the issue. As to why....I do not know but I assume since we can loop in vba but not in formulas(at least till they invented the dynamic array formula) they created the ability in the worksheet but not vba.

Therefore there is no way to simply use MATCH. We need to program our own function to simplify the entry.

Here is a paramarray version of match that accepts any number of vertical arrays of the same size or ranges of the same size and returns the relative row number:

Function myArrayMatch(ParamArray arr() As Variant) As Long
    If UBound(arr) Mod 2 <> 1 Then
        myArrayMatch = -1
        Exit Function
    End If
    Dim lgth As Long
    If TypeName(arr(LBound(arr))) = "Range" Then
        lgth = Intersect(arr(LBound(arr)).Parent.UsedRange, arr(LBound(arr))).Cells.Count
    Else
        lgth = UBound(arr(LBound(arr))) + LBound(arr(LBound(arr))) - 1
    End If
    Dim fnd() As Boolean
    ReDim fnd(1 To lgth) As Boolean

    Dim i As Long
    For i = LBound(arr) To UBound(arr) Step 2
        Dim rngarr As Variant
        If TypeName(arr(i)) = "Range" Then
            rngarr = Intersect(arr(i).Parent.UsedRange, arr(i))
        Else
            rngarr = arr(i)
        End If
        Dim j As Long
            For j = 1 To lgth
            If rngarr(j - IIf(LBound(rngarr, 1) = 0, 1, 0), 1) = arr(i + 1) Then
                If i = LBound(arr) Then fnd(j) = True
            Else
                fnd(j) = False
            End If
            If i = UBound(arr) - 1 And fnd(j) Then
                myArrayMatch = j
                Exit Function
            End If
        Next j
    Next i
    
                
End Function

It can be called like:

relRow = myArrayMatch(ActiveSheet.Range("A:A"),"X",ActiveSheet.Range("B:B"),"Y")

The range/vertical array is the odd criterion and the value to search is the even.