ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的酷贴 > Excel VBA > 如何快速地从已知地址库中查找到包含关键词语的答案？

如何快速地从已知地址库中查找到包含关键词语的答案？

作者：绿色风 分类： 时间：2022-08-18 浏览：144
楼主
chenlifeng		 我通过亲身遇到的问题，并把它解决了，现在总结如下：
问题：
    输入一个表示地名的几个字，如“湖南”、“湖南省”、“山东聊城”、“山东  聊城1”、“13广东 大良镇”等（前后可有干扰字符），如何在地址库中找到与之最符合的一个或几个详细地址？（相当于百度功能来查找地址）
    如刚才举例的几个关键词语的答案依次为：“湖南省”、“湖南省”、“山东省聊城市”、“广东省佛山市顺德区大良街道办事处”，总之，关键证词词语包括到了哪一个行政级别，地址答案就到那一级别，不往下把更详细的显示。


答案：
    附件1（名称：关键字中排干扰，地址库里显英豪）：已经成功调试，是最快、最新能排干扰的查找方式。
    在窗体输入口中输入想要查询的内容，点击“查找”，即可在一秒内找到最合适的答案（关键词语越详细越快，当只有一个字时，由于要产生的答案太多，速度较慢；而输入地名中的连续两个字，速度快到只用半秒就见答案）；

    附件2(名称：只排除后面干扰、速度时快时慢）：成功调试，速度时快时慢，当输入地址表中靠上面的行中的地址时，速度快，越靠下面的行、越靠后面的列，速度越慢。原因是它查找的方式是以行为单位查找匹配的， 而附件1是以列为查找依据、且分5个行政区，故最多只查找5列，速度自然跟上了。有关这两者的代码，见后；
   
    附件3（名称：不紧不慢）：不排除干扰，有干扰即为打不到答案。查找时，每次总是用时三秒；但思路非常有意思，代码简短，乃一朋友所作。

下面第一段代码为附件1中的部分代码，是与附件2唯一不同的地方，用的是列的方法查找，速度最快：
  1. For Each 字典2元素 In 字典2
  2.     For I = 1 To UBound(Arr)
  3.         If InStr(字典2元素, Arr(I, 1)) > 0 Then
  4.            字典2元素变体 = Replace(字典2元素, Arr(I, 1), "")
  5.            If Len(字典2元素变体) = 0 Then If Not 字典3.Exists(Arr(I, 1)) Then 字典3.Add Arr(I, 1), "": Exit For '即答案只是省名罢了
  6.            K = 重复值所在的最大行数(Range("a" & I & ":a" & Range("A65536").End(xlUp).Row), Range("a" & I).Value)
  7.                For J = I To K
  8.                    If InStr(字典2元素变体, Arr(J, 2)) > 0 Then
  9.                       If Mid(Replace(字典2元素变体, Arr(J, 2), ""), 1, 4) = "塔城地区" Then
  10.                          J = 2899: L = 2905: 字典2元素变体 = Replace(字典2元素变体, Arr(J, 2), ""): 字典2元素变体 = Replace(字典2元素变体, "塔城地区", ""): GoTo line3
  11.                       ElseIf Mid(Replace(字典2元素变体, Arr(J, 2), ""), 1, 5) = "阿勒泰地区" Then
  12.                          J = 2906: L = 2912: 字典2元素变体 = Replace(字典2元素变体, Arr(J, 2), ""): 字典2元素变体 = Replace(字典2元素变体, "阿勒泰地区", ""): GoTo line3
  13.                       End If

  15.                       字典2元素变体 = Replace(字典2元素变体, Arr(J, 2), "")
  16.                      
  17.                       If Len(字典2元素变体) = 0 Then If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2)) Then 字典3.Add Arr(I, 1) & Arr(J, 2), "": Exit For '即答案只是省和市名罢了
  18.                       L = 重复值所在的最大行数(Range("b" & I & ":b" & K), Range("b" & J).Value)
  19. line3:
  20.                          For M = J To L
  21.                              If InStr(字典2元素变体, Arr(M, 3)) > 0 Then
  22.                                 字典2元素变体 = Replace(字典2元素变体, Arr(M, 3), "")
  23.                                 If Len(字典2元素变体) = 0 Then If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2) & Arr(M, 3)) Then 字典3.Add Arr(I, 1) & Arr(J, 2) & Arr(M, 3), "": Exit For    '即答案只是省、市、乡名罢了
  24.                                 N = 重复值所在的最大行数(Range("C" & J & ":C" & L), Range("C" & M).Value)
  25.                                 For O = 4 To Range("D" & N).End(xlToRight).Column
  26.                                     If InStr(字典2元素变体, Arr(N, O)) > 0 Then
  27.                                        If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2) & Arr(M, 3) & Arr(N, O)) Then 字典3.Add Arr(I, 1) & Arr(J, 2) & Arr(M, 3) & Arr(N, O), "": Exit For   '即答案已是省、市、乡、镇了
  28.                                     ElseIf InStr(Arr(N, O), 字典2元素变体) > 0 Then
  29.                                        If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2) & Arr(M, 3) & Arr(N, O)) Then 字典3.Add Arr(I, 1) & Arr(J, 2) & Arr(M, 3) & Arr(N, O), "": Exit For   '即答案已是省、市、乡、镇了
  30.                                     End If
  31.                                 Next
  32.                              Exit For
  33.                              ElseIf InStr(Arr(M, 3), 字典2元素变体) > 0 Then
  34.                                 If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2) & Arr(M, 3)) Then 字典3.Add Arr(I, 1) & Arr(J, 2) & Arr(M, 3), "": Exit For    '即答案只是省、市、乡名罢了
  35.                              End If
  36.                          Next
  37.                   Exit For
  38.                   ElseIf InStr(Arr(J, 2), 字典2元素变体) > 0 Then
  39.                       If Not 字典3.Exists(Arr(I, 1) & Arr(J, 2)) Then 字典3.Add Arr(I, 1) & Arr(J, 2), "": Exit For '即答案只是省和市名罢了
  40.                   End If
  41.               Next
  42.         Exit For
  43.         ElseIf InStr(Arr(I, 1), 字典2元素) > 0 Then
  44.           If Not 字典3.Exists(Arr(I, 1)) Then 字典3.Add Arr(I, 1), "": Exit For '即答案只是省名罢了
  45.         End If
  46.     Next
  47. Next
附件2中的部份代码，与附件一的作用是一样的，但速度较慢：
  1.   zzz = 0   '初始化zzz，zzz有其妙用处
  2.     fo = 2    '初始华fo，它与ZZZ一样代表源地址库中的行数。
  3. line4:  '标志4

  5. For Each abc In di  'di 就是所输入的TEXTBOX1中的内容,进行了整理后的内容，每个字符中间用星号隔开。可能会循环一次或多次
  6.     cde = "*"
  7.     For bcd = 1 To Len(abc)
  8.         cde = cde & Mid(abc, bcd, 1) & "*"
  9.     Next
  10.    
  11.     For ufo = fo To Sheets("全国地址库").Range("A65536").End(xlUp).Row
  12.       For ee = 1 To Sheets("全国地址库").Range("A" & ufo).End(xlToRight).Column
  13.         If Not dic.Exists(Arr(ufo, ee)) Then
  14.             dic.Add Arr(ufo, ee), ""    'dic 是源数据 ，现在被定义为字典，向里面写数据,这一句是把每行的数据收集起来，再到下面做判断，故每一行有多少就收集多少到字典中。
  15.             ppp = Join(dic.KEYS, "")
  16.             If ppp Like cde Then '把上面收集来的数据与输入的内容比较判断，一旦符合就退出这个UFO循环， 进入下一个环节（给地址查找行政划分的单位）否则清空字典，再从上面来过。
  17.                GoTo line3
  18.             Else:
  19.                 If ee > 3 Then dic.Remove Arr(ufo, ee) 'dic.RemoveAll
  20.             End If
  21.         End If
  22.       Next
  23.         dic.RemoveAll
  24.         zzz = zzz + 1        '这里的累加，是为了后面作准备：万一下面这句是属于误判，则根据ZZZ再返回到刚才收集数据的下一行进行，而不必再从头再来，以致死循环。至于下句会出现误判的原因：如输入“蓬安”，四川省有个蓬安县，但就在这个答案的上一行有两个县（各占一单元格），一个叫太蓬乡，另个是固安乡，两者合一起就饱含了刚才的“蓬安”两字，符合下面的要求，但最后会导致答案为空。
  25.     Next
  26.    
  27. '*******下面意思是，给上面查找到的结果，赋上正确的行政划分地址，有行政地址的则免********
  28. line3:
  29.     u = abc   'abc即前面 进行了重复排查后的字典di中的元素，也是手动输入后整理出来的结果
  30.     For Each gg In dic
  31.         If InStr(u, gg) > 0 Then   '源数据中的行政地址与 U（或abc） 中的作一一对比，如果源数据的某一个数据被包括在U中，则
  32.            u = Replace(u, gg, "")  '发现两者存在重复，清除U中的内容，
  33.            dic.Remove gg           '亦清除字典dic中的重复内容
  34.            If Len(u) = 0 Then  '这里是指全部把dic中的内容匹配完了，结果为空，说明输入的内容正好是一个完整的行政划分。
  35.               If Not ddc.Exists(abc) Then ddc.Add abc, ""    '向新字典ddc 中写abc，这里表示所输入部分正好是一个完整的行政划分
  36.            End If
  37.         End If
  38.     Next

  40.     If Len(u) > 0 Then               '没有清除完的abc内容
  41.        For Each gg In dic
  42.            If InStr(gg, u) > 0 Then  '输入数据u与剩余的源数据gg作一一对比，与上面的一一对比正好相反 '如果存在重复，则:
  43.               x = Mid(gg, InStr(gg, u) + Len(u), Len(gg) - InStr(gg, u) + Len(u) - 1) '提取源数据GG中比输入数据多余的部分
  44.               y = abc & x        '再把多余的这部分与已经从最先输入的TEXTBOX1内容得了的答案di合并
  45.               If Not ddc.Exists(y) Then ddc.Add y, ""     'ddc 向新字典中写入 “所输入的TEXTBOX1内容加 所缺少内容”
  46.               Exit For  '找到后，给上述字典赋值完后，退出本轮的循环，进行新一个ABC的循环，如果字典DI有多个元素的话。
  47.            End If
  48.        Next
  49.     End If
  50. Next
  51.        If zzz = Sheets("全国地址库").Range("A65536").End(xlUp).Row Then MsgBox "没找到": Exit Sub:
  52.        If UBound(ddc.KEYS) + 1 = 0 Then:   fo = fo + zzz: GoTo line4 '这里的确UBound(ddc.keys) + 1 = 0表示数字是空？！
  53.        If UBound(ddc.KEYS) = 0 And Right(CC, 1) = "市" Then
  54.           For Each gg In ddc
  55.               If InStr(gg, Mid(CC, 1, Len(CC) - 1)) = 0 Then CC = Mid(CC, 1, Len(CC) - 1): xh = 1: ddc.RemoveAll: GoTo line0 '本行作用在于：把不是“市”的行政单位当成“市”时，去掉“市”再运行一次。如“新化县”存在，“新化市”不存在。
  56.           Next
  57.        End If
附件三的代码部分，思路不一样：
  1. For i = 2 To UBound(brr)
  2.                 If brr(i) <> "" Then
  3.                     lng = InStr(brr(i), .TextBox1) + Len(.TextBox1) - 1
  4.                     If Right(Left(brr(i), lng), Len(.TextBox1)) = .TextBox1 Then
  5.                         d(Left(brr(i), lng)) = ""
  6.                     End If
  7.                 Else
  8.                     Exit For
  9.                 End If
  10.             Next

不紧不慢.rar
只排除后面干扰、速度时快时慢.rar
关键字中排干扰，地址库里显英豪.rar
2楼
angel928		 好长的代码。
3楼
chenlifeng		 是呀，有点长，全部是窗体中的。
花了几个星期才整理学会的。学会了这些，感觉自己的水平又有一个大的提升了……

4楼
chenlifeng		 提出最终的修正：
以上的思路中，第一、二个发现了可完善的地方，我对窗体中的一段代码更新如下，主要是第11-13行作了更改，使之有及时更新功能了：
  1. Private Sub UserForm_Initialize()
  2.     Application.Volatile
  3.     Dim i&, 最初字典, J&, 四列联合$

  5.     Set 最初字典 = CreateObject("scripting.dictionary")
  6.     arr = Sheets("全国地址总库详备").UsedRange.Value
  7.     For i = 2 To UBound(arr)
  8.         四列联合 = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
  9.         最初字典(四列联合) = 0
  10.         For J = 5 To UBound(arr, 2)
  11.             If IsEmpty(arr(i, J)) Or arr(i, J) Like "*没找到*" Then
  12.             Else    'Exit For
  13.                 最初字典(四列联合 & arr(i, J)) = 0
  14.             End If
  15.         Next
  16.         四列联合 = ""
  17.     Next
  18.     原始数组 = 最初字典.keys
  19.     最初字典.RemoveAll: Set 最初字典 = Nothing
  20.     TextBox2.Value = ""
  21. End Sub

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap