【数据处理】——利用Excel VBA批量将详细地址转换成省市区三级行政区划

一、背景

导出的excel中只有详细地址，需要将详细地址解析出省市区三级行政区划

收货详细地址

湖北恩施恩施小渡船街道办事处航空大道

四川省成都市武侯石羊场街道办事处蜀绣西路

二、处理思路
1、首先想到的就是直接在excel中进行数据处理，由于数据量很大（几十万级别），因此用Java读取excel再处理的方式难度较大，也不利于非开发人员使用

2、由于详细地址中很多没有省市区相关标志，而且详细地址不规范，因此不能用截取或者正则表达式处理

3、发现LBS开放平台提供相关接口可以解析出省市区，以高德为例，地理编码就可以

URL	https://restapi.amap.com/v3/geocode/geo?parameters
请求方式	GET

4、因此需要在excel中进行编码，饭间聊天，内弟说excel中vba就可以编码，于是一试

三、处理方案

vba编码

Sub 省市区解析()
    iRows = ActiveSheet.UsedRange.Rows.Count
    Set objSC = CreateObjectx86("MSScriptControl.ScriptControl")   '在64位版Excel中的处理方法
        objSC.Language = "JScript"
    For i = 2 To iRows
    ptly = Cells(i, "E").Value
    address1 = Cells(i, "N").Value
    Address = UrlEncode(address1)
    If ptly = "XXXX" Then                         ' 只处理某种数据
    If Len(address1) > 10 Then                     ' 只处理详细地址的 用字符长度大于10判断
    URL = "http://restapi.amap.com/v3/geocode/geo?key=xxxx&address=" + Address
    Dim http As Object
    Set http = CreateObject("Microsoft.XMLHTTP")     ' 创建 http 对象以发送请求
    http.Open "GET", URL, False                      ' 设置请求地址
    http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"     '设置请求头
    http.send    '发送请求
    If http.Status = 200 Then
        Dim json$                      '定义字符串 json
        json = http.responseText       '获取相应结果
        '接下来是解析 json
        strJSON = "var json=" & json
        objSC.AddCode (strJSON)        '将 json 由字符串解析为对象
        Dim geocodes
        geocodes = objSC.Eval("json.geocodes")
        If geocodes <> "" Then
        Dim province$
        province = objSC.Eval("json.geocodes[0].province")
      If province <> "" Then
    Cells(i, "N").Value = objSC.Eval("json.geocodes[0].province")   '将省填入 Excel 表格
    Cells(i, "O").Value = objSC.Eval("json.geocodes[0].city")   '将市填入 Excel 表格
    Cells(i, "P").Value = objSC.Eval("json.geocodes[0].district")   '将区填入 Excel 表格
    End If
    End If
    End If
    End If
    End If
    Next
End Sub

Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    Static oWnd As Object
    Dim bRunning As Boolean
    #If Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    #End If
End Function


Function CreateWindow()
    Dim sSignature, oShellWnd, oProc
    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop
End Function

Function UrlEncode(ByRef szString As String) As String
       Dim szChar   As String
       Dim szTemp   As String
       Dim szCode   As String
       Dim szHex    As String
       Dim szBin    As String
       Dim iCount1  As Integer
       Dim iCount2  As Integer
       Dim iStrLen1 As Integer
       Dim iStrLen2 As Integer
       Dim lResult  As Long
       Dim lAscVal  As Long
       szString = Trim$(szString)
       iStrLen1 = Len(szString)
       For iCount1 = 1 To iStrLen1
           szChar = Mid$(szString, iCount1, 1)
           lAscVal = AscW(szChar)
           If lAscVal >= &H0 And lAscVal <= &HFF Then
              If (lAscVal >= &H30 And lAscVal <= &H39) Or _
                 (lAscVal >= &H41 And lAscVal <= &H5A) Or _
                 (lAscVal >= &H61 And lAscVal <= &H7A) Then
                 szCode = szCode & szChar
              Else
                 szCode = szCode & "%" & Hex(AscW(szChar))
              End If
           Else
              szHex = Hex(AscW(szChar))
              iStrLen2 = Len(szHex)
              For iCount2 = 1 To iStrLen2
                  szChar = Mid$(szHex, iCount2, 1)
                  Select Case szChar
                         Case Is = "0"
                              szBin = szBin & "0000"
                         Case Is = "1"
                              szBin = szBin & "0001"
                         Case Is = "2"
                              szBin = szBin & "0010"
                         Case Is = "3"
                              szBin = szBin & "0011"
                         Case Is = "4"
                              szBin = szBin & "0100"
                         Case Is = "5"
                        szBin = szBin & "0101"
                         Case Is = "6"
                              szBin = szBin & "0110"
                         Case Is = "7"
                              szBin = szBin & "0111"
                         Case Is = "8"
                              szBin = szBin & "1000"
                         Case Is = "9"
                              szBin = szBin & "1001"
                         Case Is = "A"
                              szBin = szBin & "1010"
                         Case Is = "B"
                              szBin = szBin & "1011"
                         Case Is = "C"
                              szBin = szBin & "1100"
                         Case Is = "D"
                              szBin = szBin & "1101"
                         Case Is = "E"
                              szBin = szBin & "1110"
                         Case Is = "F"
                              szBin = szBin & "1111"
                         Case Else
                  End Select
              Next iCount2
              szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
              For iCount2 = 1 To 24
                  If Mid$(szTemp, iCount2, 1) = "1" Then
                     lResult = lResult + 1 * 2 ^ (24 - iCount2)
                  Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
                  End If
              Next iCount2
              szTemp = Hex(lResult)
                    szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
           End If
            szBin = vbNullString
           lResult = 0
       Next iCount1
       UrlEncode = szCode
       End Function

处理后效

 

收货省份	收货城市	收货区县	收货详细地址
湖北省	恩施土家族苗族自治州	恩施市	湖北恩施恩施小渡船街道办事处航空大道
四川省	成都市	武侯区	四川省成都市武侯石羊场街道办事处蜀绣西路

 

四、总结

1、之前听说会用excel的人都很牛X，还有点不信，现在感觉他们确实牛

2、有些事情去做了，才发现很有意思

3、算是作为数据分析的一个开端吧，以此为记