对已实现的3级省市区地址匹配升级为5级匹配

jd23qq

地址		省	市	区县	街道	社区
北京市,市辖区,东城区,东华门街道办事处,银闸社区居委会		北京市	市辖区	东城区	东华门街道办事处	银闸社区居委会
北京市,市辖区,西城区,景山街道办事处,东厂社区居委会		北京市	市辖区	西城区	景山街道办事处	东厂社区居委会
北京市,市辖区,朝阳区,交道口街道办事处,智德社区居委会		北京市	市辖区	朝阳区	交道口街道办事处	智德社区居委会
北京市,市辖区,丰台区,安定门街道办事处,南池子社区居委会		北京市	市辖区	丰台区	安定门街道办事处	南池子社区居委会
北京市,市辖区,石景山区,北新桥街道办事处,黄图岗社区居委会		已实现	已实现	已实现	待实现	待实现
北京市,市辖区,海淀区,东四街道办事处,灯市口社区居委会
北京市,市辖区,门头沟区,朝阳门街道办事处,正义路社区居委会

1. Sub 提取省市() 'by KCFONG  学无止境，学懂说谢 2013-11-10
   
2. Rows("482:65536").ClearContents
   
3. If MsgBox("功能：根据本表A列县市区，在表“省市县代码对照表”中查找所在的省市县（区），并将结果返回到D列" & Chr(13) & Chr(13) & "重名的县区，不能正确进行匹配，手工修改再次提取会被覆盖，解决办法：将表“省市县代码对照表”中的重名县区所在行整行删除。" & Chr(13) & Chr(13) & "户名不规范的，可能不能进行匹配，返回为空，可手工输入，再次提取不会被覆盖。选【确定】立即匹配，选【取消】则放弃。", 1 + 64, "提示") = vbOK Then
   
4. 't = Timer
   
5. If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
   
6. orng = Sheets("省市县代码对照表").[a1].CurrentRegion
   
7.   With Sheets("省市县代码对照表")
   
8.         .UsedRange.Replace What:="自治区", Replacement:="", LookAt:=xlPart
   
9.        .UsedRange.Replace What:="新区", Replacement:="", LookAt:=xlPart
   
10.         .UsedRange.Replace What:="省", Replacement:="", LookAt:=xlPart
    
11.          .UsedRange.Replace What:="市", Replacement:="", LookAt:=xlPart
    
12.           .UsedRange.Replace What:="地区", Replacement:="", LookAt:=xlPart
    
13.            .UsedRange.Replace What:="盟", Replacement:="", LookAt:=xlPart
    
14.             .UsedRange.Replace What:="县", Replacement:="", LookAt:=xlPart
    
15.              .UsedRange.Replace What:="区", Replacement:="", LookAt:=xlPart
    
16.   End With
    
17. Rng = Sheets("省市县代码对照表").[a1].CurrentRegion
    
18. Sheets("省市县代码对照表").[a1].CurrentRegion = orng
    
19. 
    
20. Sheets("地址信息").Select
    
21. Application.EnableEvents = False
    
22. er = [a65536].End(xlUp).Row
    
23. Range("c2:e65536").ClearContents
    
24. rng1 = Range("a1:iv" & er)
    
25. For r = 2 To UBound(rng1)
    
26.     y = rng1(r, 1)
    
27.     For rr = 2 To UBound(Rng)
    
28.        If (y Like "*" & Rng(rr, 1) & "*" Or y Like "*" & Rng(rr, 4) & "*" And Rng(rr, 4) <> "") And (y Like "*" & Rng(rr, 2) & "*" Or y Like "*" & Rng(rr, 5) & "*" And Rng(rr, 5) <> "") And (y Like "*" & Rng(rr, 3) & "*" Or y Like "*" & Rng(rr, 6) & "*" And Rng(rr, 6) <> "") Then
    
29.                 rng1(r, 3) = orng(rr, 1): rng1(r, 4) = orng(rr, 2): rng1(r, 5) = orng(rr, 3) '省级名称    地级市名称  县级名称
    
30.                 GoTo line10:
    
31.        'ElseIf (y Like "*" & Rng(rr, 2) & "*" Or (y Like "*" & Rng(rr, 5) & "*" And Rng(rr, 5) <> "")) And (y Like "*" & Rng(rr, 3) & "*" Or (y Like "*" & Rng(rr, 6) & "*" And Rng(rr, 6) <> "")) Then
    
32.                 'rng1(r, 3) = oRng(rr, 1): rng1(r, 4) = oRng(rr, 2): rng1(r, 5) = oRng(rr, 3) '省级名称    地级市名称  县级名称
    
33.        ElseIf (y Like "*" & Rng(rr, 1) & "*" Or y Like "*" & Rng(rr, 4) & "*" And Rng(rr, 4) <> "") And (y Like "*" & Rng(rr, 3) & "*" Or y Like "*" & Rng(rr, 6) & "*" And Rng(rr, 6) <> "") Then
    
34.                 rng1(r, 3) = orng(rr, 1): rng1(r, 4) = orng(rr, 2): rng1(r, 5) = orng(rr, 3) '省级名称    地级市名称  县级名称
    
35.        End If
    
36.     Next rr
    
37.    
    
38. 
    
39. line10:
    
40. Next r
    
41. Range("a1:iv" & er) = rng1
    
42. End If
    
43. 
    
44. Application.EnableEvents = True
    
45. End Sub
    
46. 
    
47. 
    
48. 
    
49. Sub fsreset()
    
50. 
    
51. Application.EnableEvents = True
    
52. 
    
53. End Sub
    

复制代码

1. Private Sub ComboBox1_Change()
   
2. 
   
3. End Sub
   
4. 
   
5. Private Sub ListBox1_Click()
   
6. r = ActiveCell.Row
   
7. W = Split(ListBox1, "|")
   
8. 
   
9. Range("C" & r) = Trim(W(0))
   
10. Range("d" & r) = Trim(W(1))
    
11. Range("E" & r) = Trim(W(2))
    
12. ListBox1.Visible = False
    
13. End Sub
    
14. 
    
15. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
16. If Target.Count <> 1 Then Exit Sub
    
17. If Target.Column <> 1 Or Target.Row = 1 Then ListBox1.Visible = False: Exit Sub
    
18. If Target = "" Then ListBox1.Visible = False: Exit Sub
    
19. Application.EnableEvents = False
    
20. ListBox1.Clear
    
21. 
    
22. ListBox1.Top = Target.Top
    
23. ListBox1.Left = Target.Left + Target.Width
    
24. Rng = Sheets(1).[a1].CurrentRegion
    
25. List = ""
    
26. orng = Sheets("省市县代码对照表").[a1].CurrentRegion
    
27.   With Sheets("省市县代码对照表")
    
28.   '自治区
    
29.    .UsedRange.Replace What:="自治区", Replacement:="", LookAt:=xlPart
    
30.        .UsedRange.Replace What:="新区", Replacement:="", LookAt:=xlPart
    
31.         .UsedRange.Replace What:="省", Replacement:="", LookAt:=xlPart
    
32.          .UsedRange.Replace What:="市", Replacement:="", LookAt:=xlPart
    
33.           .UsedRange.Replace What:="地区", Replacement:="", LookAt:=xlPart
    
34.            .UsedRange.Replace What:="盟", Replacement:="", LookAt:=xlPart
    
35.             .UsedRange.Replace What:="县", Replacement:="", LookAt:=xlPart
    
36.              .UsedRange.Replace What:="区", Replacement:="", LookAt:=xlPart
    
37.   End With
    
38. Rng = Sheets("省市县代码对照表").[a1].CurrentRegion
    
39. Sheets("省市县代码对照表").[a1].CurrentRegion = orng
    
40.     y = Target.Text
    
41.     For rr = 2 To UBound(Rng)
    
42.        xx = orng(rr, 1) & "  |  " & orng(rr, 2) & "  |  " & orng(rr, 3)
    
43.        If (y Like "*" & Rng(rr, 1) & "*" Or y Like "*" & Rng(rr, 4) & "*" And Rng(rr, 4) <> "") And (y Like "*" & Rng(rr, 2) & "*" Or y Like "*" & Rng(rr, 5) & "*" And Rng(rr, 5) <> "") And (y Like "*" & Rng(rr, 3) & "*" Or y Like "*" & Rng(rr, 6) & "*" And Rng(rr, 6) <> "") Then
    
44.              If InStr(List, xx) = 0 Then ListBox1.AddItem xx:
    
45.               List = List & xx & ","
    
46.        End If
    
47.     Next rr
    
48.     For rr = 2 To UBound(Rng)
    
49.        xx = orng(rr, 1) & "  |  " & orng(rr, 2) & "  |  " & orng(rr, 3)
    
50.        If (y Like "*" & Rng(rr, 1) & "*" Or y Like "*" & Rng(rr, 4) & "*" And Rng(rr, 4) <> "") And (y Like "*" & Rng(rr, 3) & "*" Or y Like "*" & Rng(rr, 6) & "*" And Rng(rr, 6) <> "") Then
    
51.               If InStr(List, xx) = 0 Then ListBox1.AddItem xx:
    
52.                List = List & xx & ","
    
53.        End If
    
54.     Next rr
    
55.     For rr = 2 To UBound(Rng)
    
56.     xx = orng(rr, 1) & "  |  " & orng(rr, 2) & "  |  " & orng(rr, 3)
    
57.        If (y Like "*" & Rng(rr, 1) & "*" Or y Like "*" & Rng(rr, 4) & "*" And Rng(rr, 4) <> "") And (y Like "*" & Rng(rr, 2) & "*" Or y Like "*" & Rng(rr, 5) & "*" And Rng(rr, 5) <> "") Then
    
58.               If InStr(List, xx) = 0 Then ListBox1.AddItem xx:
    
59.                List = List & xx & ","
    
60.        End If
    
61.     Next rr
    
62. ListBox1.Visible = True
    
63. If List = "" Then
    
64.   MsgBox "Not found"
    
65.   ListBox1.Visible = False
    
66.   
    
67.   End If
    
68. 
    
69. Application.EnableEvents = True
    
70. 
    
71. End Sub
    
72. 
    
73. 
    

复制代码