読者から「VBA 住所や駅から距離を求める」に対してコメントを頂きました。
要約すると、「郵便番号を求めるVBAを知りたい」とのことです。早速試してみました。
午前2：00から開始して、解決したのが午後2：30でした...
かなりアバウトでも、それなりの精度で調べるようにしました。
結論:スマートなやり方がない
美しいやり方がないことを確信するために、6時間ちかく調べました。結局スマートなやり方がありません。
Excelで住所から郵便番号を求める方法
Excelで、郵便番号から住所を求めたい
逆に、住所から郵便番号を求めたい
これは、永遠のテーマで、よくある質問です。今回のケースでは、使えませんが、一番オススメの方法は、郵便番号を入力し、「変換」を押す方法です。IMEの機能を使う
超基本的な技ですが、知らない方が非常に多い
郵便版を入力し、「変換」キーまたは、「スペース」キーを2回押す。
※日本語入力の状態。「‐」ハイフンが必須
２回キーを押した結果
逆に住所から郵便番号もできます。この状態で「変換」キーまたは、「スペース」キーを2回押す。
結果
VBAは、自動化が目的です。おそらく2回キーを押すことすら避けたいことでしょう。
WebAPIを使用して実現
他にもいろいろな方法がありますがWebAPIを使って実現します。
このプログラムを完成させるために12時間組んで疲れましたので、ソースと結果だけ書きます。
実行画面
サンプル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 マップでクリックした場所の住所と緯度・経度と郵便番号を表示するプログラム | クリボウのプログラミングひとりごと
マイクロソフト認定トレーナー。専業ブロガーになり1年経過(別名:ひきごもり)。ブロガーなのに誤字脱字王。滑舌が悪いのにYouTuber。『自己紹介』