vlookup的加强版函数，实现近似匹配或模糊匹配

gaolzhen

分享一段自定义函数，可理解为vlookup的加强版，可实现功能：

1、根据关键字模糊匹配；
2、根据关键字近似匹配。

如图所示


希望感兴趣的大佬可再完善下分享，谢谢！

1. '    '自定义函数，有4个参数。
   
2. 
   
3. '    '第1个是查找值
   
4. 
   
5. '    '第2个是查找范围
   
6. 
   
7. '    '第3个是查找结果在查找范围的第几列
   
8. 
   
9. '    '第4个是匹配是否区分字母大小写，True区分，False不区分，默认不区分
   
10. 
    
11. 
    
12. 
    
13. Function VlookupMe(ByVal strKey As String, _
    
14. 
    
15. ByVal rngData As Range, _
    
16. 
    
17. ByVal y As Long, _
    
18. 
    
19. Optional ByVal m As Boolean = False) As String
    
20. 
    
21.     Dim i As Long, x As Long, aData
    
22. 
    
23.     Dim b As Boolean, intInstr As Long
    
24. 
    
25.     Dim strM, strRes
    
26. 
    
27.     Dim strMatches As String
    
28. 
    
29.    
    
30. 
    
31.     Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
    
32. 
    
33.     aData = rngData.Value
    
34. 
    
35.     '判断是否区分字母大小写▼
    
36. 
    
37.     If m Then strM = vbBinaryCompare Else strM = vbTextCompare
    
38. 
    
39.     strRes = "#N/A" '初始值为错误值
    
40. 
    
41.     strMatches = "" '用于存储匹配的结果
    
42. 
    
43.    
    
44. 
    
45.     For i = 1 To UBound(aData) '循环遍历数据源每行记录
    
46. 
    
47.         b = True '逻辑标记初始化
    
48. 
    
49.         For x = 1 To Len(strKey) '遍历每个字符是否都存在
    
50. 
    
51.             intInstr = InStr(1, aData(i, 1), Mid(strKey, x, 1), strM)
    
52. 
    
53.             If intInstr = 0 Then
    
54. 
    
55.                 '判断关键值在查询字符串中是否存在
    
56. 
    
57.                 b = False '如果不存在，则标记值改为false，同时退出该层循环
    
58. 
    
59.                 Exit For '没必要找下去了，退出该层循环
    
60. 
    
61.             End If
    
62. 
    
63.         Next x
    
64. 
    
65.         If b Then '如果逻辑标记仍然为true，说明全字匹配
    
66. 
    
67.             '将匹配的结果添加到字符串中，用逗号分隔
    
68. 
    
69.             strMatches = strMatches & "," & aData(i, y)
    
70. 
    
71.         End If
    
72. 
    
73.     Next i
    
74. 
    
75.    
    
76. 
    
77.     If Len(strMatches) > 0 Then
    
78. 
    
79.         '去除开头多余的逗号，返回多个匹配结果
    
80. 
    
81.         VlookupMe = Mid(strMatches, 2)
    
82. 
    
83.     Else
    
84. 
    
85.         '返回错误值
    
86. 
    
87.         VlookupMe = strRes
    
88. 
    
89.     End If
    
90. 
    
91.    
    
92. 
    
93.     Set rngData = Nothing: Erase aData
    
94. 
    
95. End Function

复制代码

ykcbf1100

现在有xlookup函数了。

GG函数

群文件或百度搜索“微软函数 for vba”，加载后你就有微软工程师(GG)的函数了

gaolzhen

GG函数 发表于 2023-6-21 18:47
群文件或百度搜索“微软函数 for vba”，加载后你就有微软工程师(GG)的函数了

谢谢！

静听溪流

点赞  鼓励支持下

gaolzhen

ykcbf1100 发表于 2023-6-21 18:46
现在有xlookup函数了。