VBA 住所や駅から距離を求める

2013年3月7日

Excel VBAを使って住所から距離を求めたいとのご要望を頂きましたので、記載します。

AM3時から作業し、AM5時に完成。もっと詳しく説明したいところですが、そろそろ会社に行かないといけないのでこのぐらいで！現在AM5時45分。

実行画面

サンプルExcel

VBA距離32bit版専用

VBAソース

 Sub aaa()

Dim l As Variant
 l = AddressToLatLng("大宮駅")
 MsgBox "lat:" & l(0) & vbCrLf & "lng:" & l(1)
 MsgBox LatLngToAddress(l(0), l(1))
 End Sub

Sub bbb()

Dim l As Variant
 l = AddressToLatLng(Range("B3").Value)
 Range("b9").Value = l(0)
 Range("c9").Value = l(1)

If l(1) = 999 Then
 Range("b14").Value = "特定できず"
 Else
 Range("b14").Value = LatLngToAddress(l(0), l(1))
 End If

l = AddressToLatLng(Range("B4").Value)
 Range("b10").Value = l(0)
 Range("c10").Value = l(1)

If l(1) = 999 Then
 Range("b15").Value = "特定できず"
 Else
 Range("b15").Value = LatLngToAddress(l(0), l(1))
 End If

If Range("b14").Value <> "特定できず" And Range("b15").Value <> "特定できず" Then

End If

Range("b18").Value = DistanceKm(Range("b9").Value, Range("c9").Value, Range("b10").Value, Range("c10").Value)

End Sub

Function DistanceKm(StartLatitude As Double, StartLongitude As Double _
 , EndLatitude As Double, EndLongitude As Double) As Double

Dim myNS As Double, myEW As Double

With Application.WorksheetFunction
 myNS = (StartLatitude - EndLatitude) / 360 * 40000#
 myEW = (StartLongitude - EndLongitude) / 360 * 40000# _
 * Cos(.Average(StartLatitude, EndLatitude) * .Pi() / 180)
 DistanceKm = (.SumSq(myNS, myEW)) ^ 0.5
 End With

End Function

'住所から緯度・経度に変換
 '戻り値は配列で、(0)が緯度、(1)が経度。
 Function AddressToLatLng(ByVal address As String) As Variant
 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
 AddressToLatLng = Array(result.geometry.location.lat, result.geometry.location.lng)
 Exit For
 Next
 Else
 'エラー
 AddressToLatLng = Array(999, 999)
 End If

Set jsn = Nothing
 Set sc = Nothing
 End Function

'緯度・経度から住所に変換
 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)
 Exit For
 Next
 Else
 'エラー
 LatLngToAddress = ""
 End If

Set jsn = Nothing
 Set sc = Nothing
 End Function