如何根据县市区匹配所在省市县区

ugyun

KCFONG 发表于 2013-11-10 21:37
see if fit your request

KCFONG 老师：
真的是不好意思再麻烦您了，您第二次的代码在数据少的情况下，完全正常，现在表里3000多个，运行出错（如下图），点调试，xx = Mid(y, d - 2, 2)这一行变成黄色，还请老师帮忙看看



匹配省市县区（第三次求助） v1.rar (100.27 KB, 下载次数: 29)

2013-11-12 09:11 上传

点击文件名下载附件

KCFONG

Bug was fixed.
New function was added.
if you select column A, listbox will be shown.
Click the listbox will input data

yjh_27

ugyun 发表于 2013-11-12 09:12
KCFONG 老师：
真的是不好意思再麻烦您了，您第二次的代码在数据少的情况下，完全正常，现在表里3000多个 ...

与KCFONG 版主的对比，有所改进

封开县社会保险基金管理局基金转移收入户      

广东省肇庆市封开县 重庆市县开县 速度有点慢，省市县代码对照表 数据整理占用不少时间  不用每次整理可提速 自治县用曾用名方式解决，同时解决改名问题。如襄樊改襄阳

yjh_27

将数据整理单独分出。

将简称、原名、其他名统一写入对应的曾用名单元格，并以“,”分隔。
将引起混淆的词组列入 需排除词组 列。如：人力资源 与 资源县。
更改数据后请按 数据整理 按钮

有二个以上选择的：在单元格输出“请选择”

省市县曾用名数据是按我理解加入，请核查调整。

yjh_27

ugyun 发表于 2013-11-12 09:12
KCFONG 老师：
真的是不好意思再麻烦您了，您第二次的代码在数据少的情况下，完全正常，现在表里3000多个 ...

又改进了。分二个过程，减少等待时间（数据整理在50s左右）。

744143025

KCFONG 发表于 2013-11-10 10:14
I had 完善本表中的代码, please test

你好老师 如何查找出这个呢根据详细地址判断行政区代码

猛哥99

谢谢分享，领教了

huang1314wei

KCFONG 发表于 2013-11-12 10:49
Bug was fixed.
New function was added.
if you select column A, listbox will be shown.

还有点小问题，麻烦大神再帮我改改代码，问题描述我放在表格里面，先谢过了
  
1.由于最新的省市区有更新,我把最新的省市区数据粘贴到了省市县代码对照表里面,并删除了不必要的代码表列,点周整理数据,出现下边越界提示.还请大神改下代码

2.黄底颜色部分比如第5行,正确应该是生成海南省海口市 龙华区,但是为什么生成的是海南省\海口市\市辖区

3.D列数据当出现错误时,点击重新选择的时候,默认全部生成了省市区,不能选择某个市,如何改成只选择对应市,E列可选项则只出现D列市下面的区县可选项

4、经常出现运行之后可选项不可选的情况
匹配省市县区1次修改.rar (128.42 KB, 下载次数: 74)

2015-4-11 12:53 上传

点击文件名下载附件

KCFONG

see if help you

chenbiao2012

1. Sub test()
   
2.     Set reg = CreateObject("vbscript.regexp")
   
3.     With reg
   
4.         .Global = True
   
5.         .Pattern = "(\S+[省市县区乡])"
   
6.     End With
   
7.     With Sheets("省市县代码对照表")
   
8.         brr = .UsedRange
   
9.     End With
   
10.     With Sheets("账户信息")
    
11.         arr = .UsedRange
    
12.         For i = 2 To UBound(arr)
    
13.             Set mat = reg.Execute(arr(i, 1))
    
14.             If mat.Count > 0 Then
    
15.                 For j = 2 To UBound(brr)
    
16.                     S = brr(j, 2) & brr(j, 3) & brr(j, 4) & brr(j, 2) & brr(j, 4) & brr(j, 3)
    
17.                     m = mat(0)
    
18.                     If InStr(S, m) > 0 Then
    
19.                         arr(i, 4) = brr(j, 2) & brr(j, 3)
    
20.                         m2 = Left(brr(j, 4), Len(brr(j, 4)) - 1)
    
21.                         If InStr(m2, m) > 0 Or InStr(m, m2) > 0 Then
    
22.                             arr(i, 5) = brr(j, 4)
    
23.                         End If
    
24.                     End If
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.         .UsedRange.Offset(1, 3).ClearContents
    
29.         .[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
30.     End With
    
31. End Sub
    

复制代码