超越LOOKUP的三个超级函数

maozhe · 发表于 2019-12-15 13:57

近期在网上收集的超级函数MLookup、Dlookup和Wlookup，以上三个函数功能均超越Lookup函数第一个函数MLookup介绍

'=Mlookup(查找内容，查找区域,返回值所在的列数,第N个,链接符号[当n=0时有效])
'语法说明:
'查找内容：除了单个值外，还可以选取多个单元格，进行多条件查找。
'查找区域: 同VLOOKUP
'返回值的在列数: 同VLOOKUP
'第N个：值为1就返回第1个符合条件的，值为2就返回第2个符合条件的....当值为-1值时，返回最后1个符合条件的值，值为0时返回所有查找结果并用逗号连接，默认为逗号，可更改！

代码如下：

Function Mlookup(rg, rgs As Range, L As Integer, M As Integer, Optional str As String = ",")
Dim arr1, ARR2, ls
Dim R, n, K, X, cc, sr As String
arr1 = rg.Value
ARR2 = rgs
If VBA.IsArray(arr1) Then
For Each R In arr1
If R <> "" Then
cc = cc & R
ls = ls + 1
End If
Next R
Else
cc = arr1
End If
If M > 0 Then '非查找最后一个
For X = 1 To UBound(ARR2)
sr = ""
If ls > 1 Then
For q = 1 To ls
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If sr = cc Then
K = K + 1
If K = M Then
Mlookup = ARR2(X, L)
Exit Function
End If
End If
Next X
ElseIf M = 0 Then '查找所有值
For X = 1 To UBound(ARR2)
sr = ""
If ls > 1 Then
For q = 1 To ls
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If sr = cc Then
Mlookup = Mlookup & str & ARR2(X, L)
End If
Next X
Mlookup = Right(Mlookup, Len(Mlookup) - 1)
Exit Function
Else '查找最后一个
For X = UBound(ARR2) To 1 Step -1
sr = ""
If ls > 1 Then
For q = 1 To ls
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If sr = cc Then
Mlookup = ARR2(X, L)
Exit Function
End If
Next X
End If
Mlookup = ""
End Function

复制代码

'=Dlookup(查找内容，待返回查找内容，查询条件,链接符号[当n=0时有效])
'语法说明:
'查找内容：单元格区域
'待返回查找内容: 单元格区域，与查找内容相同
'将所有查找结果默认逗号连接，可更改其他符号

代码如下：

Function Dlookup(rg As Range, rgs As Range, tj As Range, Optional st As String = ",") As String
Dim d As Object, arr, brr, cc As String, s As String, i As Integer
arr = rg.Value
brr = rgs.Value
cc = tj
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 1) = cc Then
s = cc
If Not d.Exists(s) Then
d(s) = brr(i, 1)
Else
d(s) = d(s) & st & brr(i, 1)
End If
End If
Next
Dlookup = d(s)
Set d = Nothing
End Function

复制代码

3、'=Wlookup(查找内容，查找区域,逆向查询拓展列，返回值所在的列数,第N个,模糊状态=0/7)
'语法说明:
'查找内容：除了单个值外，还可以选取多个单元格，进行多条件查找。
'查找区域: 同VLOOKUP
'返回值的在列数: 同VLOOKUP
'第N个：值为1就返回第1个符合条件的，值为2就返回第2个符合条件的....当值为-1值时，返回最后1个符合条件的值，值为0时返回所有查找结果并用逗号连接！

代码如下：

Function Wlookup(rg, rgs As Range, L As Integer, M As Integer, Optional P As Integer = 0)
Dim arr1, ARR2, arr3, columnn 'columnn是列数
Dim R, n, K, X, cc, sr As String
arr1 = rg.Value
If L > 0 Then ARR2 = rgs
If L < 0 Then
arr3 = rgs
ARR2 = rgs.Offset(0, L).Resize(UBound(arr3), UBound(arr3, 2) - L) 'UBound(arr3, 2)是arr3的列数，rgs需要扩展范围，将左侧L列加入其中，如原来是B2:B3，L是-1，那么扩展后就是A2:B3
End If
If VBA.IsArray(arr1) Then
For Each R In arr1
If R <> "" Then
cc = cc & R '查找值为多个单元格合并
columnn = columnn + 1
End If
Next R
Else
cc = arr1
End If
If M > 0 And L > 0 Then '非查找最后一个
For X = 1 To UBound(ARR2) 'x是数组的行数
sr = ""
If columnn > 1 Then
For q = 1 To columnn 'q是数组中列的范围
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If P = 0 And sr = cc Then
K = K + 1
If K = M Then
Wlookup = ARR2(X, L)
Exit Function
End If
End If
If P = 1 And sr Like "*" & cc & "*" Then
K = K + 1
If K = M Then
Wlookup = ARR2(X, L)
Exit Function
End If
End If
Next X
ElseIf M > 0 And L < 0 Then '非查找最后一个
For X = 1 To UBound(ARR2) 'x是数组的行数
sr = ""
If columnn > 1 Then
For q = 1 To columnn 'q是数组中列的范围，查找值是合并的，sr就是指查找值
sr = sr & ARR2(X, q - L) 'rgs已经拓展，查找列所在的位置发生变化，需要加上L列，因L是负数，使用-L转换为正数
Next q
Else
sr = ARR2(X, 1 - L) '查找值所处的位置，从拓展范围后的rgs数组的最左侧算起，
End If
If P = 0 And sr = cc Then '查找值是单个
K = K + 1
If K = M Then
Wlookup = ARR2(X, 1)
Exit Function
End If
End If
If P = 1 And sr Like "*" & cc & "*" Then '查找值是单个
K = K + 1
If K = M Then
Wlookup = ARR2(X, 1)
Exit Function
End If
End If
Next X
ElseIf M = 0 And L > 0 Then '查找所有值
For X = 1 To UBound(ARR2)
sr = ""
If columnn > 1 Then
For q = 1 To columnn
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If P = 0 And sr = cc Then
Wlookup = Wlookup & "," & ARR2(X, L)
End If
If P = 1 And sr Like "*" & cc & "*" Then
Wlookup = Wlookup & "," & ARR2(X, L)
End If
Next X
Wlookup = Right(Wlookup, Len(Wlookup) - 1)
Exit Function
ElseIf M = 0 And L < 0 Then '查找所有值
For X = 1 To UBound(ARR2)
sr = ""
If columnn > 1 Then
For q = 1 To columnn
sr = sr & ARR2(X, q - L)
Next q
Else
sr = ARR2(X, 1 - L)
End If
If P = 0 And sr = cc Then
Wlookup = Wlookup & "," & ARR2(X, 1)
End If
If P = 1 And sr Like "*" & cc & "*" Then
Wlookup = Wlookup & "," & ARR2(X, 1)
End If
Next X
Wlookup = Right(Wlookup, Len(Wlookup) - 1)
Exit Function
Else '查找最后一个
If L > 0 And M = -1 Then
For X = UBound(ARR2) To 1 Step -1
sr = ""
If columnn > 1 Then
For q = 1 To columnn
sr = sr & ARR2(X, q)
Next q
Else
sr = ARR2(X, 1)
End If
If P = 0 And sr = cc Then
Wlookup = ARR2(X, L)
Exit Function
End If
If P = 1 And sr Like "*" & cc & "*" Then
Wlookup = ARR2(X, L)
Exit Function
End If
Next X
End If
If L < 0 And M = -1 Then
For X = UBound(ARR2) To 1 Step -1
sr = ""
If columnn > 1 Then
For q = 1 To columnn
sr = sr & ARR2(X, q - L)
Next q
Else
sr = ARR2(X, 1 - L)
End If
If P = 0 And sr = cc Then
Wlookup = ARR2(X, 1)
Exit Function
End If
If P = 1 And sr Like "*" & cc & "*" Then
Wlookup = ARR2(X, 1)
Exit Function
End If
Next X
End If
End If
Wlookup = ""
End Function

复制代码

以上三个函数功能均强于Lookup
1、大量查询时DLOokup用到字典，速度最快属于速度型，Mlookup和Wlookup速度差了许多！
2、Mlookup属于标准型超功能lookup，支持多条件查询，返回类型较多！
3、Wlookup属于多功能型LOOKUP,看看代码就知道，可以逆向查询和模糊查询！
4、以上函数均在win7上32位office测试过，或许还有瑕疵，欢迎大家回电saype@qq.com

补充内容 (2019-12-19 21:06):
最新的更新在17楼，希望大家直接去17楼下载附件，附件内有模块源码！

补充内容 (2019-12-19 21:07):
最新源码与本楼的源码差距很大！

maozhe · 发表于 2019-12-19 14:27

本帖最后由 maozhe 于 2019-12-19 16:11 编辑

WYS67 发表于 2019-12-18 22:28
楼主应该用附件实例加以详细说明。需要此函数的，大多是刚入门的菜鸟，您光说功能强大没用，得用实例证明 ...

17楼附件，已经更新到最新了

maozhe · 发表于 2019-12-15 14:02

本帖最后由 maozhe 于 2019-12-17 12:46 编辑

DLOokup简记为速度型D，速度快，可以倒着查第几个！，0为返回全部
Mlookup简记为标准型M，功能比Dlookup多了，能具体返回第几个值，0是所有值合并，-1是倒数第一个
Wlookup简记为万能型W，超级功能性的lookup

'=Dlookup(查找内容tj，查找区域rg1，待返回数据区域rg2，第M个，默认为0，返回全部，连接字符st，默认为“,”)
'主要用于按条件将内容一对多的合并，dlookup使用了数组和字典功能，为速度型，
'参数M默认为0，返回全部信息，你可以随便指定不为0，当为负数时是倒着查第几个，
'连接符号可以随便更改，不算输入为默认的英文逗号！也可以通过“”取消连接符号！
'支持可以从右向左查询，把rg1和rg2换一下位置就可以了
'使用筛选查询，就是把返回的内容放在不同单元格内分别显示，当条件变化是，单元格内容跟着变化
Function Dlookup(tj As Range, rg1 As Range, rg2 As Range, Optional M As Integer = 0, Optional st As String = ",") As String
Dim d As Object, arr, brr, crr, ds As String, S As String, i As Integer
arr = rg1.Value
brr = rg2.Value
S = tj.Value
If M <> 0 Then st = "|||"
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 1) = S Then
If Not d.Exists(S) Then
d(S) = brr(i, 1)
Else
d(S) = d(S) & st & brr(i, 1)
End If
End If
Next
ds = d(S) '要是没有M参数，直接写成Dlookup = d(s)结束，结果就是查找所有！
Set d = Nothing
'有了参数M才有一下语句，先把字典值分配给变量ds，再由SPLIT函数拆分赋值给变量crr
crr = Split(ds, st)
If M = 0 Then '查找所有值
Dlookup = ds
Exit Function
ElseIf M > 0 And M < UBound(crr) + 2 Then '正向查找第几个
Dlookup = crr(M - 1)
Exit Function
ElseIf M < 0 And M > -UBound(crr) - 2 Then '逆向查找第几个
Dlookup = crr(UBound(crr) + M + 1)
Exit Function
Else '无结果
Dlookup = ""
End If
End Function
'=Mlookup(查找内容tj，查找区域rgs,返回值所在的列数L,第M个,连接字符串，默认为“,”)
'1、查找内容：除了单个值外，还可以选取多个单元格，进行多条件查找。
'2、查找区域: 同VLOOKUP
'3、返回值的在列数L: 同VLOOKUP
'4、第M个：值为1就返回第1个符合条件的，值为2就返回第2个符合条件的....当值为-1值时，返回最后1个符合条件的值，值为0时返回所有查找结果并用逗号连接
Function Mlookup(tj As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional st As String = ",") As String
Dim arr1, ARR2, Ls
Dim r, k, i As Integer, S As String, Sr As String
arr1 = tj.Value
ARR2 = rgs.Value
If VBA.IsArray(arr1) Then
For Each r In arr1
If r <> "" Then
S = S & r
Ls = Ls + 1
End If
Next r
Else
S = arr1
End If
If M > 0 Then '非查找最后一个
For i = 1 To UBound(ARR2)
Sr = ""
If Ls > 1 Then
For q = 1 To Ls
Sr = Sr & ARR2(i, q)
Next q
Else
Sr = ARR2(i, 1)
End If
If Sr = S Then
k = k + 1
If k = M Then
Mlookup = ARR2(i, L)
Exit Function
End If
End If
Next i
ElseIf M = 0 Then '查找所有值
For i = 1 To UBound(ARR2)
Sr = ""
If Ls > 1 Then
For q = 1 To Ls
Sr = Sr & ARR2(i, q)
Next q
Else
Sr = ARR2(i, 1)
End If
If Sr = S Then
Mlookup = Mlookup & st & ARR2(i, L)
End If
Next i
Mlookup = Right(Mlookup, Len(Mlookup) - Len(st))
Exit Function
Else '查找最后一个
For i = UBound(ARR2) To 1 Step -1
Sr = ""
If Ls > 1 Then
For q = 1 To Ls
Sr = Sr & ARR2(i, q)
Next q
Else
Sr = ARR2(i, 1)
End If
If Sr = S Then
Mlookup = ARR2(i, L)
Exit Function
End If
Next i
End If
Mlookup = ""
End Function
'=Wlookup(查找内容，查找区域,返回值所在的列数L,第M个数值，与原数据排列有关,P是否精确查找，默认为0，模糊查找)，
'用法同Mlookup函数
Function Wlookup(rg As Range, rgs As Range, L As Integer, Optional M As Integer = 0, Optional P As Integer = 0)
Dim arr1, ARR2, arr3, columnn 'columnn是列数
Dim r, k, X, cc, Sr As String
arr1 = rg.Value
If L > 0 Then ARR2 = rgs
If L < 0 Then
arr3 = rgs
ARR2 = rgs.Offset(0, L).Resize(UBound(arr3), UBound(arr3, 2) - L) 'UBound(arr3, 2)是arr3的列数，rgs需要扩展范围，将左侧L列加入其中，如原来是B2:B3，L是-1，那么扩展后就是A2:B3
End If
If VBA.IsArray(arr1) Then
For Each r In arr1
If r <> "" Then
cc = cc & r '查找值为多个单元格合并
columnn = columnn + 1
End If
Next r
Else
cc = arr1
End If
If M > 0 And L > 0 Then '非查找最后一个
For X = 1 To UBound(ARR2) 'x是数组的行数
Sr = ""
If columnn > 1 Then
For q = 1 To columnn 'q是数组中列的范围
Sr = Sr & ARR2(X, q)
Next q
Else
Sr = ARR2(X, 1)
End If
If P = 0 And Sr = cc Then
k = k + 1
If k = M Then
Wlookup = ARR2(X, L)
Exit Function
End If
End If
If P = 1 And Sr Like "*" & cc & "*" Then
k = k + 1
If k = M Then
Wlookup = ARR2(X, L)
Exit Function
End If
End If
Next X
ElseIf M > 0 And L < 0 Then '非查找最后一个
For X = 1 To UBound(ARR2) 'x是数组的行数
Sr = ""
If columnn > 1 Then
For q = 1 To columnn 'q是数组中列的范围，查找值是合并的，sr就是指查找值
Sr = Sr & ARR2(X, q - L) 'rgs已经拓展，查找列所在的位置发生变化，需要加上L列，因L是负数，使用-L转换为正数
Next q
Else
Sr = ARR2(X, 1 - L) '查找值所处的位置，从拓展范围后的rgs数组的最左侧算起，
End If
If P = 0 And Sr = cc Then '查找值是单个
k = k + 1
If k = M Then
Wlookup = ARR2(X, 1)
Exit Function
End If
End If
If P = 1 And Sr Like "*" & cc & "*" Then '查找值是单个
k = k + 1
If k = M Then
Wlookup = ARR2(X, 1)
Exit Function
End If
End If
Next X
ElseIf M = 0 And L > 0 Then '查找所有值
For X = 1 To UBound(ARR2)
Sr = ""
If columnn > 1 Then
For q = 1 To columnn
Sr = Sr & ARR2(X, q)
Next q
Else
Sr = ARR2(X, 1)
End If
If P = 0 And Sr = cc Then
Wlookup = Wlookup & "," & ARR2(X, L)
End If
If P = 1 And Sr Like "*" & cc & "*" Then
Wlookup = Wlookup & "," & ARR2(X, L)
End If
Next X
Wlookup = Right(Wlookup, Len(Wlookup) - 1)
Exit Function
ElseIf M = 0 And L < 0 Then '查找所有值
For X = 1 To UBound(ARR2)
Sr = ""
If columnn > 1 Then
For q = 1 To columnn
Sr = Sr & ARR2(X, q - L)
Next q
Else
Sr = ARR2(X, 1 - L)
End If
If P = 0 And Sr = cc Then
Wlookup = Wlookup & "," & ARR2(X, 1)
End If
If P = 1 And Sr Like "*" & cc & "*" Then
Wlookup = Wlookup & "," & ARR2(X, 1)
End If
Next X
Wlookup = Right(Wlookup, Len(Wlookup) - 1)
Exit Function
Else '查找最后一个
If L > 0 And M = -1 Then
For X = UBound(ARR2) To 1 Step -1
Sr = ""
If columnn > 1 Then
For q = 1 To columnn
Sr = Sr & ARR2(X, q)
Next q
Else
Sr = ARR2(X, 1)
End If
If P = 0 And Sr = cc Then
Wlookup = ARR2(X, L)
Exit Function
End If
If P = 1 And Sr Like "*" & cc & "*" Then
Wlookup = ARR2(X, L)
Exit Function
End If
Next X
End If
If L < 0 And M = -1 Then
For X = UBound(ARR2) To 1 Step -1
Sr = ""
If columnn > 1 Then
For q = 1 To columnn
Sr = Sr & ARR2(X, q - L)
Next q
Else
Sr = ARR2(X, 1 - L)
End If
If P = 0 And Sr = cc Then
Wlookup = ARR2(X, 1)
Exit Function
End If
If P = 1 And Sr Like "*" & cc & "*" Then
Wlookup = ARR2(X, 1)
Exit Function
End If
Next X
End If
End If
Wlookup = ""
End Function

复制代码

maozhe · 发表于 2019-12-15 14:50

以上是原版数据

nk0769 · 发表于 2019-12-15 20:35

看起来挺nb的

浮生若梦~~~ · 发表于 2019-12-15 21:02

楼主辛苦了

zopey · 发表于 2019-12-15 22:31

功能可能多些，感觉没有Lookup二分法的查询效率高。

maozhe · 发表于 2019-12-16 16:34

本帖最后由 maozhe 于 2019-12-17 14:34 编辑

为了大家好记忆，所有的函数参数模式都与lookup看齐，并把待返回的序号默认统一为0，可忽略，特做如下优化：1、Dlookup使用了数组和字典功能，为速度型，参数M默认为0，返回全部信息，你可以随便指定不为0，当为负数时是倒着查，连接符号可以随便更改，不算输入为默认的英文逗号！也可以通过“”取消连接符号！
'=Dlookup(查找内容tj，查找区域rg1，待返回数据区域rg2，第M个，默认为0，全部返回，连接字符串st，默认为“,”)
2、Mlookup属于标准型（Model），本次修改了默认参数M和连接符号，与Dlookup相比多了多条件查询，但查询速度较慢，是Dlookup的7倍左右，当然你也可以用&符号把查询条件连接后再用Dlookup！
3、Wlookup依旧是万能型的，可以倒着查询，当然用Dlookup也能实现，支持多条件查询！
4、以上三个函数，我比较喜欢第一个，因为它速度快，还可以指定任意元素！以上三个函数暂时不在更新，有什么问题请电邮Saype@qq.com,欢迎大家帮我完善！
最新更新到2楼

玉阳山人 · 发表于 2019-12-16 17:02

maozhe 发表于 2019-12-16 16:34
进一步优化了以上三个函数，见地址
http://club.excelhome.net/thread-1512855-1-1.html
二楼，放错地方

收藏了！慢慢消化。

maozhe · 发表于 2019-12-17 12:12

另外Dlookup 支持可以从右向左查询，把rg1和rg2换一下位置就可以了

maozhe · 发表于 2019-12-17 12:32

Dlookup不仅仅支持从右向左查询，还函数支持筛选查询

筛选查询

		自动登录	找回密码
密码			免费注册

[分享] 超越LOOKUP的三个超级函数

评分

评分

评分

评分

最新热点 /1