把区划代码表单位名称整理成省市县三级连起来的地址

yangqianming

请根据区划代码把单位名称整理成省市县三级连起来的形式，例如：河北省石家庄市高邑县的样子。谢谢！
区划代码表.rar (68.54 KB, 下载次数: 14)

2024-2-1 16:20 上传

点击文件名下载附件

cjc209

有编码对照表才好搞

yangqianming

cjc209 发表于 2024-2-1 17:10
有编码对照表才好搞

附件有编码对照表呀

cao47112

根据编码整理的，目测没啥问题

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, strJoin1$, strJoin2$, isFlag As Boolean
   
    Application.ScreenUpdating = False
   
    ar = Range("A1", Cells(Rows.Count, "B").End(xlUp)).Value
    ReDim br(1 To UBound(ar), 0): br(1, 0) = "地址"
    For i = 2 To UBound(ar)
        If Right(ar(i, 1), 4) = "0000" Then
            strJoin1 = Replace(ar(i, 2), " ", ""): br(i, 0) = strJoin1
            isFlag = True
        ElseIf Right(ar(i, 1), 2) = "00" Then
            strJoin2 = strJoin1 & Trim(ar(i, 2)): br(i, 0) = strJoin2
            isFlag = False
        Else
            If isFlag Then
                br(i, 0) = strJoin1 & Replace(ar(i, 2), "   ", "")
            Else
                br(i, 0) = strJoin2 & Replace(ar(i, 2), "   ", "")
            End If
        End If
    Next i
   
    Columns("D").Clear
    [D1].Resize(UBound(br)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件、、、

ykcbf1100

参与一下，各省市分块处理。

ykcbf1100

代码调试通过。。。

1. Sub ykcbf()  '//2024.2.3
   
2.     Dim arr, brr, i, st, zrr(1 To 1000)
   
3.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Me.Range("a1:c" & r)
   
5.     On Error Resume Next
   
6.     For i = 2 To UBound(arr)
   
7.         st = arr(i, 2)
   
8.         If Len(st) - Len(Trim(st)) = 0 Then
   
9.             m = m + 1
   
10.             zrr(m) = Array(i, i)
    
11.         End If
    
12.         If i = r Then zrr(m)(1) = r
    
13.         If Len(arr(i + 1, 2)) - Len(Trim(arr(i + 1, 2))) = 0 Then zrr(m)(1) = i
    
14.     Next
    
15.     For x = 1 To m
    
16.         r1 = zrr(x)(0): r2 = zrr(x)(1)
    
17.         For i = r1 To r2
    
18.             If i = r1 Then st1 = arr(r1, 2): arr(i, 3) = st1
    
19.             l1 = Len(arr(i, 2)): l2 = Len(Trim(arr(i, 2)))
    
20.             If l1 - l2 = 1 Then st2 = arr(i, 2): arr(i, 3) = Trim(st1 & Trim(st2))
    
21.             If l1 - l2 >= 2 Then arr(i, 3) = st1 & Trim(st2) & Trim(arr(i, 2))
    
22.         Next
    
23.     Next
    
24.     Me.[e1].Resize(UBound(arr), 3) = arr
    
25. End Sub
    
26. 
    

复制代码