excel - 使用 VBA 和数组公式方法的 VLookup with Multiple Criteria

Question

所以这个想法是利用漂亮的数组公式方法及其背后的想法，当需要在 VBA 中制作具有多个标准的 VLookUp 时。
问题:
我们可以把它翻译成 VBA:{=INDEX(range1,MATCH(1,(A1=range2)*(B1=range3)*(C1=range4),0))}根本不使用 Excel 中的公式？例如，不这样做:

=AGGREGATE(15, 6, '[TUR Master Report.xlsm]Archive'!$B$2:$B$13/
                  (('[TUR Master Report.xlsm]Archive'!$B$2:$B$13>=DO2)*
                   ('[TUR Master Report.xlsm]Archive'!$B$2:$B$13<=DP2)*
                   ('[TUR Master Report.xlsm]Archive'!$A$2:$A$13=A2)), 1)

或任何类似的东西( .ArrayFormula 、 .Formula 等)。
我在想这样的事情 foo = Match(1,(A1=rangeA)*(B1=rangeB)*(C1=rangeC),0) ，但当然它不起作用，虽然它在Excel公式的逻辑中。到目前为止，我已经创建了以下作为解决方法:

Function GetLookupDataTriple(tableName As String, lookIntoColumn As String, myArray As Variant) As Variant
    
    Dim lo As ListObject
    Set lo = Sheet1.ListObjects(tableName)
    
    Dim i As Long
    For i = 2 To lo.ListColumns(myArray(0)).Range.Rows.Count
        If lo.ListColumns(myArray(0)).Range.Cells(RowIndex:=i) = myArray(1) Then
            If lo.ListColumns(myArray(2)).Range.Cells(RowIndex:=i) = myArray(3) Then
                If lo.ListColumns(myArray(4)).Range.Cells(RowIndex:=i) = myArray(5) Then
                    GetLookupDataTriple = lo.ListColumns(lookIntoColumn).Range.Cells(RowIndex:=i)
                    Exit Function
                End If
            End If
        End If
    Next i
    
    GetLookupDataTriple = -1
    
End Function

使用 3 个过滤器效果很好，但这个想法是有点花哨，例如就像在excel原始公式中一样。这是一个示例数据，它使上述功能起作用:
?GetLookupDataTriple("Table1","To",array("From","Bulgaria","Cost",200,"Currency","USD"))

Answer 1

A) 基于 ListObject 数据的 VBA "VLookup"
当您提到 OP 中的 ListObject 时，我专注于一种完全基于 listobject 数据的方法。
作为一个实际的盈余，通过现有的表标题或索引号来识别列引用会很整洁。所以函数 multCrit() 下面返回具有任意数量列条件的给定列 (retCol) 的值。

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

在 ParamArray 中组织输入至少可能有助于保持函数调用小而清晰，例如通过以下伪语法

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

请注意，我只颠倒了 ParamArray 中的输入顺序。
需要的参数

第一个参数 data标识一个 ListObject，

第二个参数 retCol标识要返回的列(标题或索引)，

第三个基于 0 的参数 ParamArray arr()允许按以下顺序进行多个输入:

       - 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."

这种方法有条不紊地试图

获取 列数组 block 对于每个条件(一次性通过 Application.Index() - 注意使用 两个 数组参数!)

在临时数组容器内 tmp (又名锯齿状数组)和

显示值 1对于每个标准 block 中的结果(以及对于非结果的 #NV 错误 2042)。

这允许识别值 1所有指示列中的序列 block , 即使这种方法 不 处理 内置 通过在 Excel 函数中乘以 bool 值进行检查。 - 当然还有一些改进的机会(例如，找到下一个可能的项目而不是逐行循环)，但它显示了方法。
功能 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

帮助功能getCol()
返回由 标识的列数据标题 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

示例电话
请注意，该函数允许任何顺序的标题(和搜索项)输入，无论是显式还是作为范围引用；所以这个例子也演示了修改后的列顺序和范围输入:

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

可能的代码扩展 //于 2021 年 12 月 12 日编辑
如果您不坚持返回值(对于 VLookUp 解决方案很典型)，而是返回找到的数据 行 作为进一步的选择，您可以

提供例如用于将零输入 ( 0 ) 传递给参数 retCol和

更改函数的最后一个代码部分 MultCrit()如下:

                '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

然后通过 Debug.Print "*~~>", multCrit(lo, 0, "Col2", "two", "Col3", "three", "Col1", Sheet1.Range("B1")) 显示会显示例如第二行作为数字结果: ~~> 2 .

B) 通过 .Value(12) 中的 XlRangeValueDataType 枚举的简短替代//►late 截至 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.

一个 片段示例 保存列信息属性的行节点的 Col1 , Col2等可能是:

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

申请 ► FilterXML 通过 XPath 以编程方式组合所有条件条件的搜索表达式，例如此处

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

允许返回参数 retCol 传递的索引列值. *(请注意，我对原始内容进行了转换，以便在没有命名空间问题的情况下进行更轻松的搜索，参见 zrow 而不是 z:row)
在案例 A 中可以类似于 ExampleCall 调用此示例(但不会返回“可能的代码扩展”中建议的行索引)。

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