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

読者から「VBA 住所や駅から距離を求める」に対してコメントを頂きました。

要約すると、「郵便番号を求めるVBAを知りたい」とのことです。早速試してみました。

午前2:00から開始して、解決したのが午後2:30でした...

かなりアバウトでも、それなりの精度で調べるようにしました。

結論:スマートなやり方がない

美しいやり方がないことを確信するために、6時間ちかく調べました。結局スマートなやり方がありません。

Excelで住所から郵便番号を求める方法

Excelで、郵便番号から住所を求めたい

逆に、住所から郵便番号を求めたい

これは、永遠のテーマで、よくある質問です。今回のケースでは、使えませんが、一番オススメの方法は、郵便番号を入力し、「変換」を押す方法です。IMEの機能を使う

超基本的な技ですが、知らない方が非常に多い

郵便版を入力し、「変換」キーまたは、「スペース」キーを2回押す。
※日本語入力の状態。「‐」ハイフンが必須
20140601r49

2回キーを押した結果

20140601r50

逆に住所から郵便番号もできます。この状態で「変換」キーまたは、「スペース」キーを2回押す。

20140601r51

結果

20140601r52

VBAは、自動化が目的です。おそらく2回キーを押すことすら避けたいことでしょう。

WebAPIを使用して実現

他にもいろいろな方法がありますがWebAPIを使って実現します。

このプログラムを完成させるために12時間組んで疲れましたので、ソースと結果だけ書きます。

実行画面

20140601r53

サンプルExcel

VBA郵便番号32bit版専用

VBAソース

Sub 郵便番号を求める()

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

 Range("B9:E18").ClearContents
 Range("G9:I18").ClearContents

 Range("D9").Select

 AddressToLatLng (Range("B3").Value)

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
 For Each result In jsn.results
 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)

 ActiveCell.Offset(1, 0).Select
 Next
 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

参考にしたURL

Google マップでクリックした場所の住所と緯度・経度と郵便番号を表示するプログラム | クリボウのプログラミングひとりごと

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

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