模糊查询（同音字、多字或少字）或者近似查询

学不完用不尽 · 发表于 2015-9-19 11:49

本帖最后由学不完用不尽于 2015-9-20 08:42 编辑

数据规律：
      1、“数据库”工作表中的姓名，有重名现象
      2、“查询”工作表A列的姓名，有可能与“数据库”工作表的姓名是同音不同字，
            也有可能是多一个字或者少一个字


要求：
      1、根据“查询”工作表A列的姓名，提取“数据库”工作表中的姓名
      条件：
            a、“查询”表与“数据库”表中的姓名少一个字
            比如:A2和A4的“艾定”和“包强”，在“数据库”表中
            对应的有“包云强”和“包志强”两个符合条件，提取
            b、“查询”表与“数据库”表中的姓名一致，但“数据库”表中的
            姓名有重名的，应提取所有重名姓名。如：A3
            c、“查询”表与“数据库”表中的名字中出现同音字，
            提取所有同音字的姓名
            d、 B列的顺序是按照A列的姓名逐步往下排的。             也就是说，先提取符合A2单元格里的姓名，有几个就提取几个，
            依次是A3、A4、A5……，从B2单元格一直往下排。

示例如A:B列
问题参见附件：

求助模糊近似查询.rar (23.41 KB, 下载次数: 98)

在zhaogang1960老师的无私耐心的帮助下，问题已圆满解决。在此衷心地谢谢zhaogang1960老师，谢谢！！
结果参见28楼附件：

模糊近似查询.rar (106.42 KB, 下载次数: 328)

http://club.excelhome.net/forum. ... 858&pid=8382477

EH458059147 · 发表于 2015-9-19 12:25

在这个论坛搜一下工具或插件或下个罗刚君，可能会有你要的

学不完用不尽 · 发表于 2015-9-19 13:00

EH458059147 发表于 2015-9-19 12:25
在这个论坛搜一下工具或插件或下个罗刚君，可能会有你要的

能否分享一下代码？
插件或工具有时不适合自己的程序。

zhaogang1960 · 发表于 2015-9-19 14:33

留言看到，请参考：

Sub Macro1()
Dim arr, brr$(), i&, m&, s$, t$, t1$, t2$, t3$, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
On Error Resume Next
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
t = pinyin(arr(i, 1), "", 6)
If Err.Number = 0 Then
d(t) = ""
Else
Err.Clear
End If
Next
arr = Sheets("数据库").Range("a1:a" & Sheets("数据库").Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
s = arr(i, 1)
If d.Exists(s) Then
m = m + 1
brr(m, 1) = s
Else
t = pinyin(s, "", 6) 'pinyin是自定义函数，在模块2
If Err.Number = 0 Then
If d.Exists(t) Then
m = m + 1
brr(m, 1) = s
Else
If Len(s) = 3 Then
t1 = Left$(s, 1) & Right$(s, 1)
t2 = Left$(s, 1) & Mid$(s, 2, 1)
t3 = Mid$(s, 2, 1) & Right$(s, 1)
If d.Exists(t1) Or d.Exists(t2) Or d.Exists(t3) Or d.Exists(pinyin(t1, "", 6)) Or d.Exists(pinyin(t2, "", 6)) Or d.Exists(pinyin(t3, "", 6)) Then
m = m + 1
brr(m, 1) = s
End If
End If
End If
Else
Err.Clear
End If
End If
Next
[b2:b65536] = ""
[b2].Resize(m) = brr
End Sub

复制代码

zhaogang1960 · 发表于 2015-9-19 14:39

请测试附件

模糊近似查询.rar (127.98 KB, 下载次数: 210)

zhaogang1960 · 发表于 2015-9-19 15:01

本帖最后由 zhaogang1960 于 2015-9-19 15:29 编辑

上面自定义函数速度太慢，换了一个：

Sub Macro1()
Dim arr, brr$(), i&, m&, s$, t$, t1$, t2$, t3$, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
d(PinYin(arr(i, 1), "", 2)) = ""
Next
arr = Sheets("数据库").Range("a1:a" & Sheets("数据库").Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
s = arr(i, 1)
If d.Exists(s) Then
m = m + 1
brr(m, 1) = s
Else
t = PinYin(s, "", 2) 'PinYin是自定义函数，在模块2
If d.Exists(t) Then
m = m + 1
brr(m, 1) = s
Else
If Len(s) = 3 Then
t1 = Left$(s, 1) & Right$(s, 1)
t2 = Left$(s, 1) & Mid$(s, 2, 1)
t3 = Mid$(s, 2, 1) & Right$(s, 1)
If d.Exists(t1) Or d.Exists(t2) Or d.Exists(t3) Or d.Exists(PinYin(t1, "", 2)) Or d.Exists(PinYin(t2, "", 2)) Or d.Exists(PinYin(t3, "", 2)) Then
m = m + 1
brr(m, 1) = s
End If
End If
End If
End If
Next
[b2:b65536] = ""
[B2].Resize(m) = brr
End Sub

复制代码

zhaogang1960 · 发表于 2015-9-19 15:18

本帖最后由 zhaogang1960 于 2015-9-19 15:31 编辑

附件…………………………

模糊近似查询2.rar (107.11 KB, 下载次数: 266)

学不完用不尽 · 发表于 2015-9-19 15:18

zhaogang1960 发表于 2015-9-19 14:39
请测试附件

一个字：完美！
美中不足的运行速度有点慢。本机运行：
360截图20150919151558632.jpg

zhaogang1960 · 发表于 2015-9-19 15:24

学不完用不尽发表于 2015-9-19 15:18
一个字：完美！
美中不足的运行速度有点慢。本机运行：

请看7楼附件
请注意，拼音自定义函数能力有限，有些生僻字查不到，如果按照读音查找可能会有遗漏

学不完用不尽 · 发表于 2015-9-19 15:28

zhaogang1960 发表于 2015-9-19 15:18
附件…………………………

两个字：太完美了！！本机运行时间：
360截图20150919152521964.jpg

大大的提速，赞一个！！
谢谢！！！！

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

[已解决] 模糊查询（同音字、多字或少字）或者近似查询

评分

评分

评分

最新热点 /1