| 楼主 xmyjk |
Q:有一个范围涉及到全国的地址库汇总表；现在手动输入一个地址A，要从地址库中模糊查找匹配的地址，作为查询结果。 比如：地址库中有一个地址是“ 广东省佛山市顺德区大良镇”，而我手动输入的地址是“佛山 大良”，那么该函数的答案就是 库中的这个地址了。另外还需满足以下两点： 1、当输入的内容，比 实际的地址库资料 要长一些时，要求也能找到答案，如输入 “北京 通州 新华 司空” 也能找到“北京市市辖区通州区新华街道办事处”这个答案； 2、当输入的内容中不存在空格时，也能找到。如输入“涟源三甲”也能找到。 A:
 该帖已经同步到 xmyjk的微博 地址库.rar |
| 2楼 chenlifeng |
 ，有东西及时整理，这个习惯真好！成功就是由这一系列的好习惯组成的！ |
| 3楼 liu12345678jing |
有点难，没看懂。 |
| 4楼 jxcaixiaomeng |
我试试看好不好用，感谢 |
| 5楼 JOYARK1958 |
謝謝提供學習下載中 |
| 6楼 chenlifeng |
对以上贴，我已经进行了最后的整理，结果更加精准了，看起来很长，实际运行的速度还不错，如下： Option Explicit Public K, arr '查询中也出现一些特殊情况：如上海有两个一样的“青浦区”，一个是大点的行政划分，一个小点； 再如输入“蓬安”，四川省有个蓬安县，但就在这个答案的上一行有两个县，一个叫太蓬乡，另个是固安乡，两者合一起就饱含了刚才的“蓬安”两字，搜索中常找不到（已经避免）；再如陕西有个“镇巴县“，开头第一字为“镇”，此行后面亦有镇，查询不方便，等等问题，发现的已经处理了。 Private Sub CommandButton1_Click() Dim c$, jg$, i&, II&, III, j&, CC$, d, DD$, ds(), ar(), br, str, bb, m, mm, mmm, tt, abc, bcd%, cde As String Dim ee, ff, di, dic, ddc, gg, u, w, x, y, ufo, fo, ppp, zzz, t1, t2, k1, k2, K3, xh zzz = 0 Set d = CreateObject("scripting.dictionary") Set di = CreateObject("scripting.dictionary") Set dic = CreateObject("scripting.dictionary") Set ddc = CreateObject("scripting.dictionary") TextBox2.Value = "" If Len(Trim(TextBox1.Value)) = 0 Then MsgBox "并未输入查询内容，重新输入！": TextBox1.Value = "": Exit Sub '*******下面简略地对输入的内容进行处理，去除空格、TAB键及其它，并把整理的结果以单个字符，中间隔个星号，以备下一步查询******** CC = Replace(TextBox1.Value, " ", "") '替换掉空格 CC = Replace(CC, Chr$(9), "") '替换掉有可能是从其它单元格复制过来的TAB键，看起来是空格，但在工作表中用=code（）查阅，答案是9。 CC = Replace(CC, "地区", "") CC = Replace(CC, "自治区", "") CC = Replace(CC, "自治州", "") CC = Replace(CC, "自治", "") CC = Replace(CC, "省直辖行政单位", "") CC = Replace(CC, "行政单位", "") CC = Replace(CC, "特别行政区", "") If Len(CC) - Len(Replace(CC, Right(CC, 1), "")) > 1 And (Right(CC, 1) = "区" Or Right(CC, 1) = "市") Then CC = Left(CC, Len(CC) - 1) '上面一行的代码中，如果输入的关键词语最后一个字在输入的整个词语中出现了两次以上，则去掉最后这个字。为的是防止 ：当输入“北京市 市辖区 东城区”等字眼时，找到的答案是“北京市市辖区”，而没有把应该包括在内的“东城区”计算在内。在下面的“去重复内容的代码”已经表示，故本行可去除。 '*******下面的几段用于处理特殊情况，然后退出程序******* line0: ReDim ds(1 To Len(CC)) For i = 1 To Len(CC) ds(i) = Mid(CC, i, 1) Next c = "*" & Join(ds(), "*") & "*" If Right(CC, 1) = "省" Then '本句专门对付 只输入省名的情况 If Application.CountIf(Sheets("全国地址库").Range("A2:A" & Sheets("全国地址库").Range("A65536").End(xlUp).Row), TextBox1.Value) > 0 Then TextBox2.Value = CC: Exit Sub Else: MsgBox "没找到": Exit Sub End If End If If Application.CountIf(Sheets("全国地址库").Range("A2:A" & Sheets("全国地址库").Range("A65536").End(xlUp).Row), c & "市") > 0 Then '对付只输入市前面几个字，且是直辖市 TextBox2.Value = CC & "市": Exit Sub ElseIf Application.CountIf(Sheets("全国地址库").Range("A2:A" & Sheets("全国地址库").Range("A65536").End(xlUp).Row), c & "省") > 0 Then '对付只输入省前面几个字的情况 TextBox2.Value = CC & "省": Exit Sub ElseIf Application.CountIf(Sheets("全国地址库").Range("A2:A" & Sheets("全国地址库").Range("A65536").End(xlUp).Row), c & "自治区") > 0 Then '对应是自治区类型的行政划分的情况 TextBox2.Value = 匹配单元格值(Sheets("全国地址库").Range("A2:A" & Sheets("全国地址库").Range("A65536").End(xlUp).Row), c & "自治区"): Exit Sub End If '*******初步实现查询，定义字典名称是d line1: For i = 0 To UBound(K) If K(i) Like c Then If Len(CC) > 1 Then '输入两个或以上字 For II = 1 To Len(CC) DD = Mid(CC, II, 2) If InStr(K(i), DD) > 0 And Len(DD) = 2 Then d(K(i)) = 0: Exit For Next Else: MsgBox "请输入两个以上字进行查找！", 48, "友情提示：": Exit Sub 'd(k(i)) = 0 '当只输入一个字时，也能查找到答案 End If End If Next jg = Join(d.KEYS, vbCrLf) If Len(jg) > 0 Then '**********下面则是把刚得出来的数组 d 的内容进行整理，去掉重复的，生成新字典 di，如“湖南娄底”与“湖南娄底涟源”，后者算重复******************************** ar = d.KEYS str = CC For j = 1 To Len(str) For i = 0 To UBound(ar) bb = Mid(str, Len(str) + 1 - j, 1) 'bb 表示：当J为1时，是CC中的倒数第一个字符，J为2时，是倒数第二个字符，类推。 m = InStr(ar(i), bb) ' InStr只会按由前到后的顺序查找，查找到第一个后即停止查找，不管后面有没有再符合的。 If m > 0 Then mm = Len(ar(i)) - Len(Replace(ar(i), bb, "")) 'mm是在统计BB字符出现的次数 If mm > 1 Then '表示存在两个或以上的bb t1 = Mid(ar(i), m + 1, 1 + InStr(Replace(ar(i), bb, "", , 1), bb)) '如果bb出现了两次以上，这里指前两个bb之间是什么字符 mmm = InStr(Replace(ar(i), bb, "", , mm - 1), bb) 'mmm是指最后那个BB出现在CC中的第几个位置（去掉了前面的所有BB后）； If (bb = "县" Or bb = "市") Or ((InStr(ar(i), "市辖区") > 0 Or InStr(ar(i), "自治区") > 0) And bb = "区") Then If InStr(str, t1) > 0 Then '这儿是针对这种情况的，如我在窗口输入“朝阳区”时，我想要的答案是“北京市市辖区朝阳区”，但答案中出现了两个“区”，如果没有这一步，答案会是两种：一种就是刚才提到的，另一种就是去了“朝阳区”三字，即为“北京市市辖区”，出现的原因是下面判断时只以最后那个“区”为准，而InStr查找时，市辖区的“区”排列在朝阳区的“区”前面。 tt = Mid(ar(i), 1, mmm + mm - 1) '选择最后面的那个（一般情况可能第二个就是最后那个） ElseIf InStr(t1, str) > 0 Then If bb = "县" Or (bb = "市" And InStr(Mid(ar(i), 1, 3), bb) > 0) Then '这里有个3，专用于四大直辖市，当出现“重庆市县级市永川市”时，便起用； 三个“市”出现的不只是直辖市，如“长沙市济阳市文家市镇”，故刚才的条件中不用“mm>=3” tt = Mid(ar(i), 1, mmm + mm - 1) Else If InStr(Mid(ar(i), 1, m), "自治区") > 0 Then '本行专治“内蒙古自治区”等类别，当输入的是“回民区”之类的带有“区”字词语时 tt = Mid(ar(i), 1, mmm + mm - 1) Else: tt = Mid(ar(i), 1, m) '“区”的其它情况而言。 End If End If Else: tt = Mid(ar(i), 1, m) '其它情况，通通取前面的那个字作依照 End If Else If InStr(t1, str) > 0 Or InStr(str, t1) > 0 Then '当出现两个BB时，第一个与最末那个之间的部分（一般为两个BB）与STR（或CC）之间的关系，只要存在从属关系，不论是谁包含谁，都取后者：MMM+MM-1 tt = Mid(ar(i), 1, mmm + mm - 1) Else: tt = Mid(ar(i), 1, m) End If End If Else: tt = Mid(ar(i), 1, m) ': If xh = 1 Then MsgBox ar(i) & "," & tt End If If Not di.Exists(tt) Then di.Add tt, "": III = 1 End If Next If III = 1 Then GoTo line2: III = 0 '在CC中的倒数第一个字符中找到了，就不再进入倒数第二个查找，，千万注意的时，一定要记得把变量III重新赋值为0，否则答案会为空或只有一个答案。 Next line2: k1 = 0 For Each k2 In di If InStr(k2, CC) > 0 Then k1 = k1 + 1 '在新的字典里审查元素，查找与输入的内容CC有从属关系的，在下一步循环中再把它从字典中删除 Next If k1 > 0 Then '承上一步，是指存在从属关系时才执行本动作 For Each k2 In di If InStr(k2, CC) = 0 Then di.Remove k2 Next End If '下面一段，用于处理这个问题：当答案是“内蒙古自治区赤峰市红山区”与“内蒙古自治区赤峰市红山区红山工业园区”和“内蒙古自治区赤峰市红山区红山物流园区”之类时，很明显后面两个多余，去去除。 br = di.KEYS For i = 1 To UBound(br) If Right(br(i), Len(CC)) = CC Then di(br(i)) = "" Else j = InStr(br(i), CC) + Len(CC) - 1 If InStr(Right(br(i), Len(br(i)) - j), CC) <> 0 Then di(br(i)) = "" Else: di.Remove br(i) End If End If Next '**********************到此，整理重复的过程完毕********************************* '**********下面一段，为后一段赋上行政地址作准备，主要是从地址源库中，一行一行地查找符合上面字典di的行，把结果放到新字典dic中，再进入下一环节********************************** zzz = 0 '初始化zzz，zzz有其妙用处 fo = 2 '初始华fo，它与ZZZ一样代表源地址库中的行数。 line4: '标志4 For Each abc In di 'di 就是所输入的TEXTBOX1中的内容,进行了整理后的内容，每个字符中间用星号隔开。可能会循环一次或多次 cde = "*" For bcd = 1 To Len(abc) cde = cde & Mid(abc, bcd, 1) & "*" Next For ufo = fo To Sheets("全国地址库").Range("A65536").End(xlUp).Row For ee = 1 To Sheets("全国地址库").Range("A" & ufo).End(xlToRight).Column If Not dic.Exists(arr(ufo, ee)) Then dic.Add arr(ufo, ee), "" 'dic 是源数据 ，现在被定义为字典，向里面写数据,这一句是把每行的数据收集起来，再到下面做判断，故每一行有多少就收集多少到字典中。 Next ppp = Join(dic.KEYS, "") '把上面 定义好的字典赋值给变量PPP，方便下面的比较。 zzz = zzz + 1 '这里的累加，是为了后面作准备：万一下面这句是属于误判，则根据ZZZ再返回到刚才收集数据的下一行进行，而不必再从头再来，以致死循环。至于下句会出现误判的原因：如输入“蓬安”，四川省有个蓬安县，但就在这个答案的上一行有两个县（各占一单元格），一个叫太蓬乡，另个是固安乡，两者合一起就饱含了刚才的“蓬安”两字，符合下面的要求，但最后会导致答案为空。 If ppp Like cde Then '把上面收集来的数据与输入的内容比较判断，一旦符合就退出这个UFO循环， 进入下一个环节（给地址查找行政划分的单位）否则清空字典，再从上面来过。 GoTo line3 Else: dic.RemoveAll End If Next '*******下面意思是，给上面查找到的结果，赋上正确的行政划分地址，有行政地址的则免******** line3: u = abc 'abc即前面 进行了重复排查后的字典di中的元素，也是手动输入后整理出来的结果 For Each gg In dic If InStr(u, gg) > 0 Then '源数据中的行政地址与 U（或abc） 中的作一一对比，如果源数据的某一个数据被包括在U中，则 u = Replace(u, gg, "") '发现两者存在重复，清除U中的内容， dic.Remove gg '亦清除字典dic中的重复内容 If Len(u) = 0 Then '这里是指全部把dic中的内容匹配完了，结果为空，说明输入的内容正好是一个完整的行政划分。 If Not ddc.Exists(abc) Then ddc.Add abc, "" '向新字典ddc 中写abc，这里表示所输入部分正好是一个完整的行政划分 End If End If Next If Len(u) > 0 Then '没有清除完的abc内容 For Each gg In dic If InStr(gg, u) > 0 Then '输入数据u与剩余的源数据gg作一一对比，与上面的一一对比正好相反 '如果存在重复，则: x = Mid(gg, InStr(gg, u) + Len(u), Len(gg) - InStr(gg, u) + Len(u) - 1) '提取源数据GG中比输入数据多余的部分 y = abc & x '再把多余的这部分与已经从最先输入的TEXTBOX1内容得了的答案di合并 If Not ddc.Exists(y) Then ddc.Add y, "" 'ddc 向新字典中写入 “所输入的TEXTBOX1内容加 所缺少内容” Exit For '找到后，给上述字典赋值完后，退出本轮的循环，进行新一个ABC的循环，如果字典DI有多个元素的话。 End If Next End If Next If zzz = Sheets("全国地址库").Range("A65536").End(xlUp).Row Then MsgBox "没找到": Exit Sub: If UBound(ddc.KEYS) + 1 = 0 Then: fo = fo + zzz: GoTo line4 '这里的确UBound(ddc.keys) + 1 = 0表示数字是空？！ If UBound(ddc.KEYS) = 0 And Right(CC, 1) = "市" Then For Each gg In ddc If InStr(gg, Mid(CC, 1, Len(CC) - 1)) = 0 Then CC = Mid(CC, 1, Len(CC) - 1): xh = 1: ddc.RemoveAll: GoTo line0 '本行作用在于：把不是“市”的行政单位当成“市”时，去掉“市”再运行一次。如“新化县”存在，“新化市”不存在。 Next End If TextBox2.Value = Join(ddc.KEYS, vbCrLf) Else c = Left(c, Len(c) - 2) '当找不到时，把输入的关键词语从末尾起减少一个再看。（这里的C包含星号，故这样算） If Len(c) = 1 Then TextBox2.Value = "没找到": Set d = Nothing: Exit Sub GoTo line1 End If Erase ds Set di = Nothing: Set di = Nothing: d.RemoveAll: Set d = Nothing ddc.RemoveAll: Set ddc = Nothing End Sub Private Sub UserForm_Initialize() Dim i&, d, j&, ssx$ Set d = CreateObject("scripting.dictionary") arr = Sheets("全国地址库").UsedRange.Value For i = 2 To UBound(arr) ssx = arr(i, 1) & arr(i, 2) & arr(i, 3) d(ssx) = 0 For j = 4 To UBound(arr, 2) If IsEmpty(arr(i, j)) Or arr(i, j) Like "*没找到*" Then Exit For d(ssx & arr(i, j)) = 0 Next ssx = "" Next K = d.KEYS d.RemoveAll: Set d = Nothing TextBox2.Value = "" End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Erase K End Sub |
| 7楼 chenlifeng |
另还有一答案，基本和上面差不多，简短很多，仅是后面的地址没有进行行政匹配罢了： Public brr(1 To 100000) Sub test() Dim d As Object, arr, i, j, s$ arr = Range("a1").CurrentRegion Set d = CreateObject("scripting.dictionary") s = InputBox("请输入关键词语", "请输入") For i = 1 To UBound(arr) If Right(arr(i, 1), Len(s)) = s Then d(arr(i, 1)) = "" Else j = InStr(arr(i, 1), s) + Len(s) - 1 If InStr(Right(arr(i, 1), Len(arr(i, 1)) - j), s) <> 0 Then d(arr(i, 1)) = "" End If Next MsgBox Join(d.KEYS, vbCrLf) End Sub Sub 筛选() Dim arr, i&, j&, k&, rng As Range, s$, t, d t = Timer Set rng = Sheet2.Range("a1").CurrentRegion Set d = CreateObject("scripting.dictionary") arr = Range("a2").Resize(rng.Rows.Count - 1, rng.Columns.Count) k = 1 For i = 1 To UBound(arr) s = arr(i, 1) & arr(i, 2) & arr(i, 3) For j = 4 To UBound(arr, 2) If arr(i, j) = "未找到" Then arr(i, j) = "" If s & arr(i, j) <> brr(k) Then k = k + 1 brr(k) = s & arr(i, j) End If Next s = "" Next MsgBox brr End Sub Sub 显示窗体() UserForm1.Show 0 End Sub '以上是在模块中的代码，下面是窗体中的代码： Option Explicit Private Sub CommandButton1_Click() Dim arr(), i&, s$, lng%, d As Object With Me If .TextBox1 = "" Then MsgBox "第一关键字不能为空!", vbCritical, "错误提示" .TextBox1 = "" .TextBox2 = "" .TextBox1.SetFocus Exit Sub End If 筛选 Set d = CreateObject("scripting.dictionary") If .TextBox2 <> "" Then For i = 2 To UBound(brr) If brr(i) <> "" Then lng = InStr(brr(i), .TextBox2) + Len(.TextBox2) - 1 If Right(Left(brr(i), lng), Len(.TextBox2)) = .TextBox2 Then If InStr(Left(brr(i), lng), .TextBox1) <> 0 Then d(Left(brr(i), lng)) = "" End If End If Else Exit For End If Next Else For i = 2 To UBound(brr) If brr(i) <> "" Then lng = InStr(brr(i), .TextBox1) + Len(.TextBox1) - 1 If Right(Left(brr(i), lng), Len(.TextBox1)) = .TextBox1 Then d(Left(brr(i), lng)) = "" End If Else Exit For End If Next End If .ListBox1.List = d.KEYS .Label6 = "一共有 " & d.Count & " 个满足条件的记录!" End With End Sub Private Sub CommandButton2_Click() With Me .TextBox1 = "" .TextBox2 = "" .ListBox1.Clear .Label6 = "" .TextBox1.SetFocus End With End Sub Private Sub CommandButton3_Click() Unload Me End Sub End Sub Private Sub UserForm_Initialize() With Me .TextBox1 = "" .TextBox2 = "" .TextBox1.SetFocus End With End Sub 地址查询与匹配.rar |
| 8楼 living88 |
哈哈，代码都非常的哇 |