求大神帮助批量补全省市区地址信息，谢谢！

long237043787

如图所示，增加了sheet2表里对应数据后，能把提取不到的地址又提取出一部分，还有一部分是加上对应省市区县也不能提取的，还请大神再帮忙看看，谢谢！

long237043787

cbtaja 发表于 2016-5-16 23:48

麻烦极速蜗牛大大再次帮忙看看，增加了对应省市区县后，还有部分无法提取出来，谢谢！

long237043787

麻烦大家帮忙顶一下啊，拜谢中……

long237043787

麻烦极速蜗牛大大再次帮忙看看，增加了对应省市区县后，还有部分无法提取出来，谢谢！

long237043787

Sub test()
If Not flag Then Call createIndex
sens = Join(sen.Keys, "|")
shis = Join(shi.Keys, "|")
arr = Sheet2.Range("A1").CurrentRegion.Resize(, 8).Offset(1)
r = UBound(arr)
Set reg1 = CreateObject("vbscript.regexp")
reg1.Global = True
reg1.Pattern = sens

Set reg2 = CreateObject("vbscript.regexp")
reg2.Global = True
reg2.Pattern = shis
brr = Sheet1.Range("A1").CurrentRegion.Resize(, 1)
ReDim crr(1 To UBound(brr), 1 To 2)
crr(1, 1) = "省、市、区县": crr(1, 2) = "街道栋号"
For i = 2 To UBound(brr)
    sid = ""
    star = 1: send = r
    If reg1.test(brr(i, 1)) Then
        Set matches = reg1.Execute(brr(i, 1))
        sid = sen(matches(0).Value)
    End If
   
    If reg2.test(brr(i, 1)) Then
        Set matches = reg2.Execute(brr(i, 1))
        sid = shi(matches(0).Value)
    End If
    If sid <> "" Then
    starend = Split(sid, "|")
    star = starend(0):
    send = starend(1)
    End If
   
    For j = star To send
        
        If Len(arr(j, 7)) Then
            n = InStr(brr(i, 1), arr(j, 7))
            If n Then
                tmpstr = ""
                For k = 3 To 8
                    tmpstr = tmpstr & arr(j, k)
                    If k = 4 Or k = 6 Then tmpstr = tmpstr & " "
                Next
                crr(i, 1) = tmpstr
                crr(i, 2) = brr(i, 1)
                Do While n > 0
               
                    crr(i, 2) = Mid(crr(i, 2), n + Len(arr(j, 7)))
                    Select Case Left(crr(i, 2), 1)
                    Case "市", "区", "县", "州"
                        crr(i, 2) = Mid(crr(i, 2), 2)
                    Case "自"
                        crr(i, 2) = Mid(crr(i, 2), 4)
                    Case Else
                    End Select
                    n = InStr(crr(i, 2), arr(j, 7))
                Loop
            End If
        End If
    Next
Next
Sheet1.Range("A1").CurrentRegion.Resize(, 2).Offset(, 1) = crr
End Sub

long237043787

这是极速蜗牛大大写的程式，我增加了对应省市区县后，还有部分无法提取出来，请大神们帮忙看下，小弟vba小白

long237043787

请大神关注11楼附件，谢谢！

yjh_27

long237043787 发表于 2016-5-19 15:20
请大神关注11楼附件，谢谢！

参见附件。

long237043787

这个是提取了省市，但是省市后面的详细地址怎么分割出来呢？需要放到同一行里的。

yjh_27

long237043787 发表于 2016-5-19 19:19
这个是提取了省市，但是省市后面的详细地址怎么分割出来呢？需要放到同一行里的。

补充  省市县代码对照表
增加 详细地址

我的代码 已考虑了：
同名县（区）  

广东省

白云区

贵州省

白云区

地址长度 优先匹配

内蒙古自治区

白云矿区

可设置曾用、缩写
如：襄阳 襄樊
       二连浩特市 二连市
可屏蔽详细地址中的干扰词
如 平安保险公司

青海省

平安县

这需在省市县代码对照表 自行补充完善。