用VBA和数组公式法实现多准则VLOOKUP [英] VLookup with Multiple Criteria with VBA and the array formula method
问题描述
因此，当需要在VBA中创建具有多个条件的VLOOKUP时，我们的想法是利用美丽的数组公式方法及其背后的思想。
问题： 我们能否将其转换为VBA：
{=INDEX(range1,MATCH(1,(A1=range2)*(B1=range3)*(C1=range4),0))}
=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"))
推荐答案
A)基于ListObject数据
当您在OP中引用ListObject时，我重点介绍了一种完全基于列表对象数据的方法。
作为实际盈余，通过现有的表头或索引号标识列引用是很好的。因此，下面的函数multCrit()返回具有任意数量的列条件的给定列(retCol)的值。
作为幻想，我正在寻找这样的东西foo = Match(1,(A1=rangeA)*(B1=rangeB)*(C1=rangeC),0)，
小而善解人意。
在ParamArray中组织输入可能至少有助于保持Small和Clear的函数调用，例如，通过以下伪语法
multCrit(lo, ReturnColumn, ParamArray:{Col1, search1, Col2, search2,...})
请注意，我只颠倒了参数数组中的输入顺序。
所需参数
- 第一个参数
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)
我猜在VBA中应该有内置的方法来实现这一点。
此方法有条不紊地尝试
- 为每个条件获取列数组块(通过
Application.Index()-注意使用了两个数组参数！) - 在临时数组容器
tmp中(也称为交错数组)和 - 显示每个条件块中调查结果的值
1(非调查结果显示#NV错误2042)。
这允许在所有指示的列块中标识1序列，即使此方法不会像在Excel函数中那样通过将布尔值相乘来处理内置检查。-当然还有几个改进的机会(例如，找到下一个可能的项目，而不是逐行循环)，但它显示了方法。
函数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。
这种有条不紊的新方法完全基于
.Value(xlRangeValueMSPersistXML)-的字符串分析，它将指定(ListObject)范围的记录集表示形式返回为XML格式的字符串。
- 包含列信息属性
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>
通过XPath以编程方式组合所有条件的搜索表达式，对此(稍微转换)内容应用►FilterXML，如此处
"//zrow[@Col3='two' and @Col4='three' and @Col2='one']/@Col1"`
允许返回通过参数retCol传递的索引列值。*(请注意，我转换原始内容是为了使搜索更容易，而不会出现命名空间问题，c.f.zrow而不是z:row)
此示例可以类似于在A情况下调用ExampleCall(但不会返回&qot；可能的代码扩展&中建议的行索引)。
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
这篇关于用VBA和数组公式法实现多准则VLOOKUP的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
