VBA 複数の住所や駅から郵便番号を求める

前回、読者の要望により、「VBA 住所や駅から郵便番号を求める」を作成しました。

マンション名だけで、郵便番号と住所がわかるので、私も喜んでいます。とても便利です。

今回、A列に列挙して、複数個同時に調べたいとのことでしたので、2時間ほどかけて作成しました。

20140601r130

WebAPIを使用して実現

他にもいろいろな方法がありますが、前回のWebAPIをそのまま流用しただけです。

実行画面

20140601r132

サンプルExcel

VBA郵便番号複数対応版 32bit版専用

VBAソース

Sub 郵便番号を求める()

 '文字列から経度・緯度を求める

 Range("B9:F62").ClearContents
 Range("H9:H62").ClearContents

 Range("L9:P62").ClearContents
 Range("Q9:Q62").ClearContents

 Range("U9:X62").ClearContents
 Range("Z9:Z62").ClearContents

 Range("AD9:AG62").ClearContents
 Range("AI9:AI62").ClearContents

 Range("AM9:AP62").ClearContents
 Range("AR9:AR62").ClearContents

 Range("AV9:AY62").ClearContents
 Range("BA9:BA62").ClearContents

 Range("E9").Select

 Dim i As Integer
 i = 9
 Do While Cells(i, 1).Value <> ""
 AddressToLatLng (Cells(i, 1).Value)
 i = i + 1
 Loop

 Cells.Font.ColorIndex = 0

End Sub

'住所から緯度・経度に変換
'戻り値は配列で、(0)が緯度、(1)が経度
Sub AddressToLatLng(ByVal address As String)
Dim sc As Object
Dim jsn As Object
Dim result As Object
Dim http As Object
Dim url As String
Dim status, results, location As String

 Set sc = CreateObject("ScriptControl")
 sc.Language = "JScript"
 sc.AddCode "function getLatLng(s) { return eval('(' + s + ')');}"

 url = "http://maps.google.com/maps/api/geocode/json?sensor=false&address=" & sc.CodeObject.encodeURI(address)

 Set http = CreateObject("MSXML2.XMLHTTP")
 http.Open "GET", url, False
 http.Send
 Set jsn = sc.CodeObject.getLatLng(http.ResponseText)

 If jsn.status = "OK" Then
 Dim i As Integer
 i = 0
 For Each result In jsn.results
 If i < 6 Then
 ActiveCell.Value = result.geometry.location.lat
 ActiveCell.Offset(0, 1).Value = result.geometry.location.lng

 ActiveCell.Offset(0, 3).Value = result.formatted_address

 ActiveCell.Offset(0, -1).Value = LatLngToAddress(result.geometry.location.lat, result.geometry.location.lng)

 ActiveCell.Offset(0, -2).Value = AddressToPostcode(ActiveCell.Offset(0, 4).Value)

 End If
 ActiveCell.Offset(0, 9).Select

 i = i + 1
 Next
 ActiveCell.Offset(0, i * -9).Select
 ActiveCell.Offset(0, -3).Value = i
 ActiveCell.Offset(1, 0).Select
 End If

 Set jsn = Nothing
 Set sc = Nothing
End Sub

'緯度・経度から住所に変換
Function LatLngToAddress(ByVal lat As Double, ByVal lng As Double) As String
Dim sc As Object
Dim jsn As Object
Dim result As Object
Dim http As Object
Dim url As String
Dim text As String
 Set sc = CreateObject("ScriptControl")
 sc.Language = "JScript"
 sc.AddCode "function getAddress(s) { return eval('(' + s + ')');}"

 url = "http://maps.google.com/maps/api/geocode/json?sensor=false&language=ja&latlng=" & lat & "," & lng

 Set http = CreateObject("MSXML2.XMLHTTP")
 http.Open "GET", url, False
 http.Send
 'ReplaceはShift_JISに無いハイフンが返されるためこれを全角ハイフンに変換
 Set jsn = sc.CodeObject.getAddress(Replace(http.ResponseText, ChrW(&H2212), "-"))
 If jsn.status = "OK" Then
 For Each result In jsn.results
 '「日本, 住所」の形で格納されてるので住所部分のみを取得
 LatLngToAddress = Split(result.formatted_address, ", ", 2)(1)
 'もし一文字目が郵便番号なら削る
 If Left(LatLngToAddress, 1) = "〒" Then
 LatLngToAddress = Mid(LatLngToAddress, 11)
 End If
 Exit For
 Next
 Else
 'エラー
 LatLngToAddress = "特定できず"
 End If

 Set jsn = Nothing
 Set sc = Nothing
End Function

'住所から郵便番号に変換
Function AddressToPostcode(InputAddress As String) As String
Dim sc As Object
Dim jsn As Object
Dim result As Object
Dim http As Object
Dim url As String
Dim text As String
 Set sc = CreateObject("ScriptControl")
 sc.Language = "JScript"
 sc.AddCode "function zipSearch(s) { return eval('(' + s + ')');}"

 url = "http://api.postalcode.jp/v1/zipsearch?word=" & sc.CodeObject.encodeURI(InputAddress)

 Set http = CreateObject("MSXML2.XMLHTTP")
 http.Open "GET", url, False
 http.Send

 Set jsn = sc.CodeObject.zipSearch(http.ResponseText)

 On Error Resume Next
 AddressToPostcode = jsn.zipcode.a1.zipcode

 Set jsn = Nothing
 Set sc = Nothing
End Function

まとめ:プログラムは楽しい

みなさんもぜひ、自作して楽しんでくださいね!

デバック用: FB:0 TW:2 Po:0 B:0 G+:0 Pin:0 L:0

ツイート 2  このエントリーをはてなブックマークに追加