ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 4599|回复: 33

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 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, 下载次数: 62)

TA的精华主题

TA的得分主题

发表于 2015-9-19 12:25 | 显示全部楼层
在这个论坛搜 一下工具或插件或下个罗刚君,可能会有你要的

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-9-19 13:00 | 显示全部楼层
EH458059147 发表于 2015-9-19 12:25
在这个论坛搜 一下工具或插件或下个罗刚君,可能会有你要的

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

TA的精华主题

TA的得分主题

发表于 2015-9-19 14:33 | 显示全部楼层
留言看到,请参考:
  1. Sub Macro1()
  2.     Dim arr, brr$(), i&, m&, s$, t$, t1$, t2$, t3$, d As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
  5.     On Error Resume Next
  6.     For i = 1 To UBound(arr)
  7.         d(arr(i, 1)) = ""
  8.         t = pinyin(arr(i, 1), "", 6)
  9.         If Err.Number = 0 Then
  10.             d(t) = ""
  11.         Else
  12.             Err.Clear
  13.         End If
  14.     Next
  15.     arr = Sheets("数据库").Range("a1:a" & Sheets("数据库").Range("a65536").End(xlUp).Row)
  16.     ReDim brr(1 To UBound(arr), 1 To 1)
  17.     For i = 1 To UBound(arr)
  18.         s = arr(i, 1)
  19.         If d.Exists(s) Then
  20.             m = m + 1
  21.             brr(m, 1) = s
  22.         Else
  23.             t = pinyin(s, "", 6) 'pinyin是自定义函数,在模块2
  24.             If Err.Number = 0 Then
  25.                 If d.Exists(t) Then
  26.                     m = m + 1
  27.                     brr(m, 1) = s
  28.                 Else
  29.                     If Len(s) = 3 Then
  30.                         t1 = Left$(s, 1) & Right$(s, 1)
  31.                         t2 = Left$(s, 1) & Mid$(s, 2, 1)
  32.                         t3 = Mid$(s, 2, 1) & Right$(s, 1)
  33.                         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
  34.                             m = m + 1
  35.                             brr(m, 1) = s
  36.                         End If
  37.                     End If
  38.                 End If
  39.             Else
  40.                 Err.Clear
  41.             End If
  42.         End If
  43.     Next
  44.     [b2:b65536] = ""
  45.     [b2].Resize(m) = brr
  46. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
学不完用不尽 + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-9-19 14:39 | 显示全部楼层
请测试附件
模糊近似查询.rar (127.98 KB, 下载次数: 89)

TA的精华主题

TA的得分主题

发表于 2015-9-19 15:01 | 显示全部楼层
本帖最后由 zhaogang1960 于 2015-9-19 15:29 编辑

上面自定义函数速度太慢,换了一个:

  1. Sub Macro1()
  2.     Dim arr, brr$(), i&, m&, s$, t$, t1$, t2$, t3$, d As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
  5.     For i = 1 To UBound(arr)
  6.         d(arr(i, 1)) = ""
  7.         d(PinYin(arr(i, 1), "", 2)) = ""
  8.     Next
  9.     arr = Sheets("数据库").Range("a1:a" & Sheets("数据库").Range("a65536").End(xlUp).Row)
  10.     ReDim brr(1 To UBound(arr), 1 To 1)
  11.     For i = 1 To UBound(arr)
  12.         s = arr(i, 1)
  13.         If d.Exists(s) Then
  14.             m = m + 1
  15.             brr(m, 1) = s
  16.         Else
  17.             t = PinYin(s, "", 2) 'PinYin是自定义函数,在模块2
  18.             If d.Exists(t) Then
  19.                 m = m + 1
  20.                 brr(m, 1) = s
  21.             Else
  22.                 If Len(s) = 3 Then
  23.                     t1 = Left$(s, 1) & Right$(s, 1)
  24.                     t2 = Left$(s, 1) & Mid$(s, 2, 1)
  25.                     t3 = Mid$(s, 2, 1) & Right$(s, 1)
  26.                     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
  27.                         m = m + 1
  28.                         brr(m, 1) = s
  29.                     End If
  30.                 End If
  31.             End If
  32.         End If
  33.     Next
  34.     [b2:b65536] = ""
  35.     [B2].Resize(m) = brr
  36. End Sub
复制代码


评分

参与人数 1鲜花 +2 收起 理由
学不完用不尽 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-9-19 15:18 | 显示全部楼层
本帖最后由 zhaogang1960 于 2015-9-19 15:31 编辑

附件…………………………
模糊近似查询2.rar (107.11 KB, 下载次数: 118)

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-9-19 15:18 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-9-19 15:24 | 显示全部楼层
学不完用不尽 发表于 2015-9-19 15:18
一个字:完美!
美中不足的运行速度有点慢。本机运行:

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-9-19 15:28 | 显示全部楼层
zhaogang1960 发表于 2015-9-19 15:18
附件…………………………

两个字:太完美了!!本机运行时间:
360截图20150919152521964.jpg
大大的提速,赞一个!!
谢谢!!!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-8-24 14:42 , Processed in 0.100148 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表