一、背景
导出的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:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 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、算是作为数据分析的一个开端吧，以此为记
