VLookUp⼀对多升级版，可以返回所有匹配结果，⽀持多列或多⾏作为搜索和返
回区域
函数名称：LookUpAllMatches
参数使⽤⽅法
lookup_value查值。必填字段。填写需要查的值，或者选择需要查的值所在的单元格。
match_range匹配区域。必填字段。选取lookup_value的查区域，也就是你要在哪⾥lookup_value。通常选取⼀整列。
return_range返回区域。必填字段。选取需要返回的区域，通常选取与match_range相邻的某⼀列。也就是说，当你在match_range的某⼀⾏中到lookup_value后，你要返回这⼀⾏中哪⼀列的值，或者说，你要返回这⼀⾏与哪⼀列相交处的单元格的值。
return_array 是否返回数组。可选参数。默认值为False，不返回数组，将所有匹配返回到⼀个单元格中，⽤逗号隔开。如果填True，函数就会返回数组，即把匹配结果返回到多个单元格内。这时需要将该公式中的引⽤转换为绝对引⽤，并复制到多个单元格，同时选中这些单元格后，按ctrl+shift+enter结束
输⼊。此时公式会被⼀对⼤括号"{}"包括，意为该函数为数组函数(array formula)，他的返回结果分散在多个单元格中。
remove_duplicate是否去除返回结果中的重复项。可选参数。默认值为False，即不开启去除重复功能。填True开启去重功能。
delimiter分隔符。可选参数。默认值为英⽂逗号","。该参数⽤来⾃定义返回结果中的分隔符。如果return_array填true，则该参数失效。
已经包含该函数代码的xlsm⽂件下载链接：
打开该⽂件后需开启宏。
如需在输⼊函数时获取参数提⽰，可以先在单元格中输⼊=LookUpAllMatches()，然后按Shift+F3，就会弹出参数输⼊辅助界⾯。如下图。
如果您想学习⼀下如何⾃⼰插⼊VBA源代码，可以按照以下⽅法将下⽂中的VBA代码插⼊Excel⼯作簿：
先在Excel中按Alt+F11，进⼊VBE编辑器。然后在左侧到需要插⼊代码的⼯作簿(Workbook)的名称。如果VBE编辑器左侧看不到这⼀块Project⼩窗⼝，可以试试看按Ctrl+R。在下图中，我希望在⼯作簿Book1中插⼊代码，所以就选中了VBAProject (Book1)这⼀层。
右键单击该⼯作簿名称，依次点击Insert -- Module。
这时VBE左侧就会多出⼀个Module1，双击该Module1，在右侧代码输⼊界⾯中，将本⽂下⾯的代码复制粘贴进去。
本⾃定义函数由于使⽤了第三⽅库，使⽤前需要做Early Binding：即在VBE编辑器中，选择菜单栏中的Tool — Reference：
弹出如下图的对话框后，选择Microsoft Scripting Runtime，打钩，点OK。
最后按Ctrl+S保存⽂件，注意在保存对话框中，⽂件类型需要选择“Excel启动宏的⼯作簿(*.xlsm)”，如下图
Function LookUpAllMatches(ByVal lookup_value As String, ByVal match_range As Range, _
ByVal return_range As Range, Optional ByVal return_array = False, _
Optional ByVal remove_duplicate = False, Optional ByVal delimiter As String = ",")
'By Jing He 2017-12-29
'Last update 2018-02-02
Dim match_index() As Long, result_set() As String
ReDim match_index(1 To match_range.Cells.Count)
Set match_range = zTrim_Range(match_range)
Set return_range = zTrim_Range(return_range)
If match_range.Count <> return_range.Count Then
LookUpAllMatches = "Number of cells in trimed match_range and in trimed return_range are not equal."
Exit Function
End If
Dim i As Long, mc As Long  'used to count, to get the index of a cell in a range
mc = 0'match count
For i = 1 To match_range.Cells.Count
If match_range.Cells(i).Value = lookup_value Then
mc = mc + 1
match_index(mc) = i
End If
Next i
If mc = 0 Then Exit Function
'Removing duplicate process. Use Scripting.Dictionary object.
If remove_duplicate Then
Dim d As Dictionary, key As String
Set d = New Dictionary
For i = 1 To mc
key = return_range.Cells(match_index(i)).Value
If Not d.Exists(key) Then d.Add key, key
Next i
ReDim result_set(1 To d.Count)
'Convert the hashtable to a array of all the values
its = d.Items
'the index of this items array starts at 0 instead of 1 which is the standard for all the other arraries in ths UDF.    For i = 0 To d.Count - 1
result_set(i + 1) = its(i)
Next i
'close the object; release memeory
Set d = Nothing
Else
ReDim result_set(1 To mc)
For i = 1 To mc
result_set(i) = return_range.Cells(match_index(i)).Value
Next i
End If
If return_array Then
LookUpAllMatches = result_set
Exit Function
End If
Dim result As String
'Convert result_set to a single-line text
多列vlookup函数的使用方法result = result_set(1)
For i = 2 To UBound(result_set)
result = result & delimiter & result_set(i)
Next i
LookUpAllMatches = result
End Function
Function zTrim_Range(ByVal rng As Range) As Range
'By Jing He 2017-12-29
'Last update 2017-12-29
Dim maxRow As Long, maxUsedRow As Long, maxUsedRowTemp As Long
maxRow = Columns(1).Cells.Count
If rng.Cells.Count \ maxRow <> 0 Then
'One or multiple columns selected
For i = 1 To rng.Columns.Count
If Cells(maxRow, rng.Cells(1, i).Column) = "" Then
maxUsedRowTemp = Cells(maxRow, rng.Cells(1, i).Column).End(xlUp).Row
If maxUsedRowTemp > maxUsedRow Then maxUsedRow = maxUsedRowTemp
End If
Next i
Set zTrim_Range = Intersect(rng, Range(Rows(1), Rows(maxUsedRow))) Else
Set zTrim_Range = rng
End If
End Function

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。