1437189907 Excelのマクロを使って2つの住所の直線距離を求めたいです。


今、Sheet1のA1セルに、大阪にある通天閣の住所が記載されております。
A2セルに四天王寺、A3セルに大阪城と、周辺のスポットの住所が記載されています。
そういうスポット情報が、A2セルから2万行ぐらいあります。

この状況から、A1セルの通天閣の住所と、各セルの住所の直線距離を調べ、その距離をB列などに出力するような。
そんな処理がもし可能でしたら、お教えいただきたいのですが。
2点間の距離を調べられるサイトは多く見つけられたのですが、一度に処理できる方法を見つけることが出来ませんでして。

よろしくお願い致します。

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2015/07/18 12:25:07
  • 終了:2015/07/23 22:37:43

ベストアンサー

id:a-kuma3 No.2

a-kuma3回答回数4607ベストアンサー獲得回数19442015/07/20 11:48:51

ポイント3000pt

Google Maps API の Geocoding API で緯度と経度を求めて、直線距離をヒュベニの公式で求めます。
まずは、VBA のコードを先に。
標準モジュールに貼り付けて、距離を求めたいシートを開いた状態で、SetDistance サブルーチンを実行してください。

Const LAT_COLUMN = 27
Const LNG_COLUMN = LAT_COLUMN + 1
Const DISTANCE_COLUMN = 2

Const MAX_ROWS = 20000


Function SetLocation(addr, lat, lng)
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    result = "-"

    URL = "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & addr.Value
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set geo = doc.getElementsByTagName("geometry")
            Set Location = geo(0).FirstChild
            lat.Value = Location.FirstChild.Text
            lng.Value = Location.LastChild.Text
            result = "OK"
        Else
            result = Status.Text
            Debug.Print Status.Text
        End If

    Else
        result = xhr.StatusText
    End If

    Set xhr = Nothing

    If result <> "OK" Then
        lat.Value = "×"
        lng.Value = "×"
    End If

    SetLocation = result

End Function


Function deg2rad(deg)
    PI = Application.WorksheetFunction.PI()
    deg2rad = deg * PI / 180#
End Function

Function CalcDistance(lat1, lng1, lat2, lng2)

    If IsNumeric(lat1) And IsNumeric(lat2) Then
        a = 6378137#
        e2 = 6.69438002301188E-03
        mnum = 6335439.32708317    ' a * (1.0 - e2)

        my = deg2rad((lat1 + lat2) / 2#)
        dy = deg2rad(lat1 - lat2)
        dx = deg2rad(lng1 - lng2)

        s = Sin(my)
        w = Sqr(1# - e2 * s * s)
        m = mnum / (w * w * w)
        n = a / w

        dym = dy * m
        dxncos = dx * n * Cos(my)

        CalcDistance = Sqr(dym * dym + dxncos * dxncos)

    Else

        CalcDistance = "×"

    End If

End Function


Function is_need_calc(c)
    If IsEmpty(c) Or Not IsNumeric(c.Value) Then
        is_need_calc = True
    Else
        is_need_calc = False
    End If
End Function


Sub SetDistance()

    ' from
    i = 1
    If is_need_calc(Cells(1, LAT_COLUMN)) Then
        result = SetLocation(Cells(i, 1), Cells(i, LAT_COLUMN), Cells(i, LNG_COLUMN))
    End If
    from_lat = Cells(1, LAT_COLUMN).Value
    from_lng = Cells(1, LNG_COLUMN).Value
    
    ' to
    For i = 2 To MAX_ROWS
        Set cell_addr = Cells(i, 1)
        If IsEmpty(cell_addr) Or cell_addr.Value = "" Then
            Exit Sub
        End If
        Set cell_lat = Cells(i, LAT_COLUMN)
        Set cell_lng = Cells(i, LNG_COLUMN)

        If is_need_calc(cell_lat) Then
            result = SetLocation(cell_addr, cell_lat, cell_lng)
            If result = "OVER_QUERY_LIMIT" Then
                ' maybe limits of a second. wait and retry
                Application.Wait Now + TimeValue("00:00:02")
                result = SetLocation(cell_addr, cell_lat, cell_lng)
                If result = "OVER_QUERY_LIMIT" Then
                    ' maybe limits of a day (24H)
                    MsgBox "maybe excess limits of a day."
                    Exit Sub
                End If
            End If
        End If

        DoEvents

        d = CalcDistance(from_lat, from_lng, cell_lat.Value, cell_lng.Value)
        Cells(i, DISTANCE_COLUMN).Value = d
    Next

End Sub

Google Maps API には、以下の回数制限があります。

Users of the free API:

  • 2500 requests per 24 hour period.
  • 5 requests per second.
The Google Geocoding API   |   Google Maps Geocoding API   |   Google Developers

一秒に5回までの制限はウェイトをかませて対処しています。
速度や混み具合によって変わりますが、5~10件くらいを処理しては 1秒の待ちが入って処理を続けます。
なので 24時間あたりの制限である 2500件を処理するのに 8~10分くらいかかるんじゃないでしょうか。

24時間あたりで2500回の制限は待つしかありません。
きれいに取得できたとして、20000件で 8日間はかかることになります。
24時間あたりの制限回数にかかったと思われる場合には、メッセージボックスを表示して処理を中断します。
No.1 の回答を試している場合には、既に回数を使い切っている可能性が大きいです。
24時間待ってから、試してみてください。

回数制限があるので、API を使って調べた緯度と経度はシートに残して、無駄にリクエストを出さないようにします。
緯度と経度は、AA列とAB列に残すようにしました。
既に使っている列であれば、コードの先頭にある LAT_COLUMN の値を変更してください。
経度は、緯度の次の列を使うようにしています。

最大の処理件数も、コードで持っちゃってます。
20000件以上は、MAX_ROWS の値を大きくしてください。

ヒュベニの公式については、以下のようなところを参考にしました。
先のコードでは、GRS80 という測地系を使った数値を採用しています。
http://www.amano-tec.com/apps/paceruler.html
http://hp.vector.co.jp/authors/VA002244/yacht/geo.htm
http://www.trail-note.net/tech/calc_distance/
http://homepage3.nifty.com/-ms/doc/calc_distance.htm
http://yamadarake.jp/trdi/report000001.html



ちなみに、本当に直線距離で良いんですか?
道路を使った経路の距離ではなく。

Google Maps API の Distance Matrix API というのを使うと、経路での距離も求められます。
こちらも回数制限があるので、全件求めるにはそれなりに時間がかかります。
2地点間の緯度と経度から経路距離を求めるサービスなので、この回答のコードで求めた緯度、経度が利用できます。





追記です。

それはすごいです!お手数ですがもし可能でしたら、道路を使った経路の2住所間の距離を求める方法も、お教えいただきたいのですが。
また、住所から緯度経度の取得も可能なのでしょうか?
もし可能でしたら、B~D列に「緯度」「経度」「2住所間の距離」の3つの情報を反映できると助かるのですが。

先の回答でも、緯度と経度は AA列とAB列に残すようにしてます :-)
以下の変更を加えます。

  • 緯度、経度、A1 との距離 を、B~D列に書き込みます
  • 距離は、Google Maps Distance Matrix API を使って、車での移動距離を求めます

マクロのコードはこちら。

Const LAT_COLUMN = 2
Const LNG_COLUMN = LAT_COLUMN + 1
Const DISTANCE_COLUMN = 4

Const MAX_ROWS = 20000


Function SetLocation(addr, lat, lng)
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    result = "-"

    URL = "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & addr.Value
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set geo = doc.getElementsByTagName("geometry")
            Set Location = geo(0).FirstChild
            lat.Value = Location.FirstChild.Text
            lng.Value = Location.LastChild.Text
            result = "OK"
        Else
            result = Status.Text
            Debug.Print Status.Text
        End If

    Else
        result = xhr.StatusText
    End If

    Set xhr = Nothing

    If result <> "OK" Then
        lat.Value = "×"
        lng.Value = "×"
    End If

    SetLocation = result

End Function


Function deg2rad(deg)
    PI = Application.WorksheetFunction.PI()
    deg2rad = deg * PI / 180#
End Function

' ヒュベニの公式で、2地点間の直線距離を求める
Function CalcDistance(lat1, lng1, lat2, lng2)

    If IsNumeric(lat1) And IsNumeric(lat2) Then
        a = 6378137#
        e2 = 6.69438002301188E-03
        mnum = 6335439.32708317    ' a * (1.0 - e2)

        my = deg2rad((lat1 + lat2) / 2#)
        dy = deg2rad(lat1 - lat2)
        dx = deg2rad(lng1 - lng2)

        s = Sin(my)
        w = Sqr(1# - e2 * s * s)
        m = mnum / (w * w * w)
        n = a / w

        dym = dy * m
        dxncos = dx * n * Cos(my)

        CalcDistance = Sqr(dym * dym + dxncos * dxncos)

    Else

        CalcDistance = "×"

    End If

End Function

' Google Maps Distance Matrix API を使って、2地点間の距離を求める
Function CalcDistance2(lat1, lng1, lat2, lng2)

    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    URL = "https://maps.googleapis.com/maps/api/distancematrix/xml?" _
        & "origins=" & lat1 & "," & lng1 _
        & "&destinations=" & lat2 & "," & lng2

    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set d = doc.getElementsByTagName("distance")
            CalcDistance2 = d(0).FirstChild.Text
        Else
            CalcDistance2 = "×"
        End If

    Else
        CalcDistance2 = "×"
    End If

    Set xhr = Nothing


End Function


Function is_need_calc(c)
    If IsEmpty(c) Or Not IsNumeric(c.Value) Then
        is_need_calc = True
    Else
        is_need_calc = False
    End If
End Function

Sub test()
    result = SetLocation(Cells(1, 1), Cells(1, 3), Cells(1, 4))
    result = SetLocation(Cells(2, 1), Cells(2, 3), Cells(2, 4))
'    d = CalcDistance(Cells(1, 3).Value, Cells(1, 4).Value, Cells(2, 3).Value, Cells(2, 4).Value)
    d = CalcDistance2(Cells(1, 3).Value, Cells(1, 4).Value, Cells(2, 3).Value, Cells(2, 4).Value)
    Cells(2, 2).Value = d
End Sub

Sub SetDistance()

    ' from
    i = 1
    If is_need_calc(Cells(1, LAT_COLUMN)) Then
        result = SetLocation(Cells(i, 1), Cells(i, LAT_COLUMN), Cells(i, LNG_COLUMN))
    End If
    from_lat = Cells(1, LAT_COLUMN).Value
    from_lng = Cells(1, LNG_COLUMN).Value
    
    ' to
    For i = 2 To MAX_ROWS
        Set cell_addr = Cells(i, 1)
        If IsEmpty(cell_addr) Or cell_addr.Value = "" Then
            Exit Sub
        End If
        Set cell_lat = Cells(i, LAT_COLUMN)
        Set cell_lng = Cells(i, LNG_COLUMN)

        If is_need_calc(cell_lat) Then
            result = SetLocation(cell_addr, cell_lat, cell_lng)
            If result = "OVER_QUERY_LIMIT" Then
                ' maybe limits of a second. wait and retry
                Application.Wait Now + TimeValue("00:00:02")
                result = SetLocation(cell_addr, cell_lat, cell_lng)
                If result = "OVER_QUERY_LIMIT" Then
                    ' maybe limits of a day (24H)
                    MsgBox "maybe excess limits of a day."
                    Exit Sub
                End If
            End If
        End If

        DoEvents

        d = CalcDistance2(from_lat, from_lng, cell_lat.Value, cell_lng.Value)
        Cells(i, DISTANCE_COLUMN).Value = d
    Next

End Sub

関数 CalcDistance2 のコードを追加して、SetDistance サブルーチンで使う距離を求める関数を置き換えました(ヒュベニの公式を使った関数も残してあります)。

因みに、距離を求めるのに使った Distance Matrix API にも回数制限があります。

Users of the free API:

  • 100 elements per query.
  • 100 elements per 10 seconds.
  • 2500 elements per 24 hour period.
The Google Distance Matrix API   |   Google Maps Distance Matrix API   |   Google Developers

距離を求めるのも計算式から、Webサービスに変えているので、その分は遅くなります。
制限にかかるとしたら、Geocoding API と同じく 24時間あたりで 2500回まで、という制限だと思います。

他4件のコメントを見る
id:a-kuma3

むう。status が OK で返ってるのに、distance が取得できないことがあるのですか……
やり直すと正しく動くということは、処理ができない住所があるということではないんですよね。
ちょっと試行錯誤してみます。

2015/07/22 08:11:41
id:a-kuma3

他の方から指摘がありまして、Google Map API って、こういう使い方は禁止されているんだそうです。

The Geocoding API may only be used in conjunction with a Google map; geocoding results without displaying them on a map is prohibited. For complete details on allowed usage, consult the Maps API Terms of Service License Restrictions.

The Google Geocoding API   |   Google Maps Geocoding API   |   Google Developers

(c) No Mass Downloads or Bulk Feeds of Content. You must not use the Service in a manner that gives you or any other person access to mass downloads or bulk feeds of any Content, including but not limited to numerical latitude or longitude coordinates, imagery, visible map data, or places data (including business listings). For example, you are not permitted to offer a batch geocoding service that uses Content contained in the Maps API(s).

Google Maps/Google Earth APIs Terms of Service   |   Google Maps APIs   |   Google Developers
2015/07/27 15:11:01

その他の回答(1件)

id:bnn No.1

bnn回答回数67ベストアンサー獲得回数202015/07/18 14:29:14

ポイント700pt

面白そうだったので、調べてみました。

いくつか注意点

  • GoogleAPIの制限があるようですが、大量の住所を持っていないため一度にどれだけ利用可能かテストしていません。
  • GoogleAPIで住所の座標を出し、地球を半径約6378kmの球体とした場合の座標間距離を計算していますので多少誤差が生じています。

もっと正確で効率の良いコードは本職の方にお任せします。

f:id:bnn:20150718141723p:image

Sub GetLocation(address As String, ByRef lat As String, ByRef lng As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "http://maps.googleapis.com/maps/api/geocode/json?address="
    lastVal = "&sensor=false"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(address, " ", "+") & lastVal
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, """lat""") = 0 Then GoTo ErrorHandl
    tmpVal = Right(objHTTP.responseText, Len(objHTTP.responseText) - InStr(objHTTP.responseText, """lat"" : ") - 7)
    lat = Split(tmpVal, ",")(0)
    tmpVal = Right(objHTTP.responseText, Len(objHTTP.responseText) - InStr(objHTTP.responseText, """lng"" : ") - 7)
    lng = Replace(Split(tmpVal, "}")(0), " ", "")
    Exit Sub
ErrorHandl:
    lat = lng = 0
End Sub

Private Function Distance(latitude1, longitude1, latitude2, longitude2)
earth_radius = 6378137
Pi = 3.14159265
deg2rad = Pi / 180
dLat = deg2rad * (latitude2 - latitude1)
dLon = deg2rad * (longitude2 - longitude1)
a = Sin(dLat / 2) * Sin(dLat / 2) + Cos(deg2rad * latitude1) * Cos(deg2rad * latitude2) * Sin(dLon / 2) * Sin(dLon / 2)
c = 2 * WorksheetFunction.Asin(Sqr(a))
d = earth_radius * c
Distance = Round(d)
End Function

Public Function GetDistance(address1 As String, address2 As String)
Dim lat1 As String, lng1 As String, lat2 As String, lng2 As String
Call GetLocation(address1, lat:=lat1, lng:=lng1)
Call GetLocation(address2, lat:=lat2, lng:=lng2)
GetDistance = Distance(lat1, lng1, lat2, lng2)
End Function

参考:
http://www.analystcave.com/excel-get-geolocation-coordinates-of-an-address/
http://www.codecodex.com/wiki/Calculate_distance_between_two_points_on_a_globe#Excel

他1件のコメントを見る
id:magi-cocolog

回答者の貼っている画像のように、B列に計算式を入れるのですよ

2015/07/19 13:29:10
id:moon-fondu

bnnさんありがとうございます、うまく求めることができました!

2015/07/21 01:56:09
id:a-kuma3 No.2

a-kuma3回答回数4607ベストアンサー獲得回数19442015/07/20 11:48:51ここでベストアンサー

ポイント3000pt

Google Maps API の Geocoding API で緯度と経度を求めて、直線距離をヒュベニの公式で求めます。
まずは、VBA のコードを先に。
標準モジュールに貼り付けて、距離を求めたいシートを開いた状態で、SetDistance サブルーチンを実行してください。

Const LAT_COLUMN = 27
Const LNG_COLUMN = LAT_COLUMN + 1
Const DISTANCE_COLUMN = 2

Const MAX_ROWS = 20000


Function SetLocation(addr, lat, lng)
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    result = "-"

    URL = "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & addr.Value
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set geo = doc.getElementsByTagName("geometry")
            Set Location = geo(0).FirstChild
            lat.Value = Location.FirstChild.Text
            lng.Value = Location.LastChild.Text
            result = "OK"
        Else
            result = Status.Text
            Debug.Print Status.Text
        End If

    Else
        result = xhr.StatusText
    End If

    Set xhr = Nothing

    If result <> "OK" Then
        lat.Value = "×"
        lng.Value = "×"
    End If

    SetLocation = result

End Function


Function deg2rad(deg)
    PI = Application.WorksheetFunction.PI()
    deg2rad = deg * PI / 180#
End Function

Function CalcDistance(lat1, lng1, lat2, lng2)

    If IsNumeric(lat1) And IsNumeric(lat2) Then
        a = 6378137#
        e2 = 6.69438002301188E-03
        mnum = 6335439.32708317    ' a * (1.0 - e2)

        my = deg2rad((lat1 + lat2) / 2#)
        dy = deg2rad(lat1 - lat2)
        dx = deg2rad(lng1 - lng2)

        s = Sin(my)
        w = Sqr(1# - e2 * s * s)
        m = mnum / (w * w * w)
        n = a / w

        dym = dy * m
        dxncos = dx * n * Cos(my)

        CalcDistance = Sqr(dym * dym + dxncos * dxncos)

    Else

        CalcDistance = "×"

    End If

End Function


Function is_need_calc(c)
    If IsEmpty(c) Or Not IsNumeric(c.Value) Then
        is_need_calc = True
    Else
        is_need_calc = False
    End If
End Function


Sub SetDistance()

    ' from
    i = 1
    If is_need_calc(Cells(1, LAT_COLUMN)) Then
        result = SetLocation(Cells(i, 1), Cells(i, LAT_COLUMN), Cells(i, LNG_COLUMN))
    End If
    from_lat = Cells(1, LAT_COLUMN).Value
    from_lng = Cells(1, LNG_COLUMN).Value
    
    ' to
    For i = 2 To MAX_ROWS
        Set cell_addr = Cells(i, 1)
        If IsEmpty(cell_addr) Or cell_addr.Value = "" Then
            Exit Sub
        End If
        Set cell_lat = Cells(i, LAT_COLUMN)
        Set cell_lng = Cells(i, LNG_COLUMN)

        If is_need_calc(cell_lat) Then
            result = SetLocation(cell_addr, cell_lat, cell_lng)
            If result = "OVER_QUERY_LIMIT" Then
                ' maybe limits of a second. wait and retry
                Application.Wait Now + TimeValue("00:00:02")
                result = SetLocation(cell_addr, cell_lat, cell_lng)
                If result = "OVER_QUERY_LIMIT" Then
                    ' maybe limits of a day (24H)
                    MsgBox "maybe excess limits of a day."
                    Exit Sub
                End If
            End If
        End If

        DoEvents

        d = CalcDistance(from_lat, from_lng, cell_lat.Value, cell_lng.Value)
        Cells(i, DISTANCE_COLUMN).Value = d
    Next

End Sub

Google Maps API には、以下の回数制限があります。

Users of the free API:

  • 2500 requests per 24 hour period.
  • 5 requests per second.
The Google Geocoding API   |   Google Maps Geocoding API   |   Google Developers

一秒に5回までの制限はウェイトをかませて対処しています。
速度や混み具合によって変わりますが、5~10件くらいを処理しては 1秒の待ちが入って処理を続けます。
なので 24時間あたりの制限である 2500件を処理するのに 8~10分くらいかかるんじゃないでしょうか。

24時間あたりで2500回の制限は待つしかありません。
きれいに取得できたとして、20000件で 8日間はかかることになります。
24時間あたりの制限回数にかかったと思われる場合には、メッセージボックスを表示して処理を中断します。
No.1 の回答を試している場合には、既に回数を使い切っている可能性が大きいです。
24時間待ってから、試してみてください。

回数制限があるので、API を使って調べた緯度と経度はシートに残して、無駄にリクエストを出さないようにします。
緯度と経度は、AA列とAB列に残すようにしました。
既に使っている列であれば、コードの先頭にある LAT_COLUMN の値を変更してください。
経度は、緯度の次の列を使うようにしています。

最大の処理件数も、コードで持っちゃってます。
20000件以上は、MAX_ROWS の値を大きくしてください。

ヒュベニの公式については、以下のようなところを参考にしました。
先のコードでは、GRS80 という測地系を使った数値を採用しています。
http://www.amano-tec.com/apps/paceruler.html
http://hp.vector.co.jp/authors/VA002244/yacht/geo.htm
http://www.trail-note.net/tech/calc_distance/
http://homepage3.nifty.com/-ms/doc/calc_distance.htm
http://yamadarake.jp/trdi/report000001.html



ちなみに、本当に直線距離で良いんですか?
道路を使った経路の距離ではなく。

Google Maps API の Distance Matrix API というのを使うと、経路での距離も求められます。
こちらも回数制限があるので、全件求めるにはそれなりに時間がかかります。
2地点間の緯度と経度から経路距離を求めるサービスなので、この回答のコードで求めた緯度、経度が利用できます。





追記です。

それはすごいです!お手数ですがもし可能でしたら、道路を使った経路の2住所間の距離を求める方法も、お教えいただきたいのですが。
また、住所から緯度経度の取得も可能なのでしょうか?
もし可能でしたら、B~D列に「緯度」「経度」「2住所間の距離」の3つの情報を反映できると助かるのですが。

先の回答でも、緯度と経度は AA列とAB列に残すようにしてます :-)
以下の変更を加えます。

  • 緯度、経度、A1 との距離 を、B~D列に書き込みます
  • 距離は、Google Maps Distance Matrix API を使って、車での移動距離を求めます

マクロのコードはこちら。

Const LAT_COLUMN = 2
Const LNG_COLUMN = LAT_COLUMN + 1
Const DISTANCE_COLUMN = 4

Const MAX_ROWS = 20000


Function SetLocation(addr, lat, lng)
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    result = "-"

    URL = "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & addr.Value
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set geo = doc.getElementsByTagName("geometry")
            Set Location = geo(0).FirstChild
            lat.Value = Location.FirstChild.Text
            lng.Value = Location.LastChild.Text
            result = "OK"
        Else
            result = Status.Text
            Debug.Print Status.Text
        End If

    Else
        result = xhr.StatusText
    End If

    Set xhr = Nothing

    If result <> "OK" Then
        lat.Value = "×"
        lng.Value = "×"
    End If

    SetLocation = result

End Function


Function deg2rad(deg)
    PI = Application.WorksheetFunction.PI()
    deg2rad = deg * PI / 180#
End Function

' ヒュベニの公式で、2地点間の直線距離を求める
Function CalcDistance(lat1, lng1, lat2, lng2)

    If IsNumeric(lat1) And IsNumeric(lat2) Then
        a = 6378137#
        e2 = 6.69438002301188E-03
        mnum = 6335439.32708317    ' a * (1.0 - e2)

        my = deg2rad((lat1 + lat2) / 2#)
        dy = deg2rad(lat1 - lat2)
        dx = deg2rad(lng1 - lng2)

        s = Sin(my)
        w = Sqr(1# - e2 * s * s)
        m = mnum / (w * w * w)
        n = a / w

        dym = dy * m
        dxncos = dx * n * Cos(my)

        CalcDistance = Sqr(dym * dym + dxncos * dxncos)

    Else

        CalcDistance = "×"

    End If

End Function

' Google Maps Distance Matrix API を使って、2地点間の距離を求める
Function CalcDistance2(lat1, lng1, lat2, lng2)

    Set xhr = CreateObject("MSXML2.ServerXMLHTTP")

    URL = "https://maps.googleapis.com/maps/api/distancematrix/xml?" _
        & "origins=" & lat1 & "," & lng1 _
        & "&destinations=" & lat2 & "," & lng2

    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
    
        Set doc = xhr.responseXML.DocumentElement
        Set Status = doc.FirstChild     ' status
        If Status.Text = "OK" Then
            Set d = doc.getElementsByTagName("distance")
            CalcDistance2 = d(0).FirstChild.Text
        Else
            CalcDistance2 = "×"
        End If

    Else
        CalcDistance2 = "×"
    End If

    Set xhr = Nothing


End Function


Function is_need_calc(c)
    If IsEmpty(c) Or Not IsNumeric(c.Value) Then
        is_need_calc = True
    Else
        is_need_calc = False
    End If
End Function

Sub test()
    result = SetLocation(Cells(1, 1), Cells(1, 3), Cells(1, 4))
    result = SetLocation(Cells(2, 1), Cells(2, 3), Cells(2, 4))
'    d = CalcDistance(Cells(1, 3).Value, Cells(1, 4).Value, Cells(2, 3).Value, Cells(2, 4).Value)
    d = CalcDistance2(Cells(1, 3).Value, Cells(1, 4).Value, Cells(2, 3).Value, Cells(2, 4).Value)
    Cells(2, 2).Value = d
End Sub

Sub SetDistance()

    ' from
    i = 1
    If is_need_calc(Cells(1, LAT_COLUMN)) Then
        result = SetLocation(Cells(i, 1), Cells(i, LAT_COLUMN), Cells(i, LNG_COLUMN))
    End If
    from_lat = Cells(1, LAT_COLUMN).Value
    from_lng = Cells(1, LNG_COLUMN).Value
    
    ' to
    For i = 2 To MAX_ROWS
        Set cell_addr = Cells(i, 1)
        If IsEmpty(cell_addr) Or cell_addr.Value = "" Then
            Exit Sub
        End If
        Set cell_lat = Cells(i, LAT_COLUMN)
        Set cell_lng = Cells(i, LNG_COLUMN)

        If is_need_calc(cell_lat) Then
            result = SetLocation(cell_addr, cell_lat, cell_lng)
            If result = "OVER_QUERY_LIMIT" Then
                ' maybe limits of a second. wait and retry
                Application.Wait Now + TimeValue("00:00:02")
                result = SetLocation(cell_addr, cell_lat, cell_lng)
                If result = "OVER_QUERY_LIMIT" Then
                    ' maybe limits of a day (24H)
                    MsgBox "maybe excess limits of a day."
                    Exit Sub
                End If
            End If
        End If

        DoEvents

        d = CalcDistance2(from_lat, from_lng, cell_lat.Value, cell_lng.Value)
        Cells(i, DISTANCE_COLUMN).Value = d
    Next

End Sub

関数 CalcDistance2 のコードを追加して、SetDistance サブルーチンで使う距離を求める関数を置き換えました(ヒュベニの公式を使った関数も残してあります)。

因みに、距離を求めるのに使った Distance Matrix API にも回数制限があります。

Users of the free API:

  • 100 elements per query.
  • 100 elements per 10 seconds.
  • 2500 elements per 24 hour period.
The Google Distance Matrix API   |   Google Maps Distance Matrix API   |   Google Developers

距離を求めるのも計算式から、Webサービスに変えているので、その分は遅くなります。
制限にかかるとしたら、Geocoding API と同じく 24時間あたりで 2500回まで、という制限だと思います。

他4件のコメントを見る
id:a-kuma3

むう。status が OK で返ってるのに、distance が取得できないことがあるのですか……
やり直すと正しく動くということは、処理ができない住所があるということではないんですよね。
ちょっと試行錯誤してみます。

2015/07/22 08:11:41
id:a-kuma3

他の方から指摘がありまして、Google Map API って、こういう使い方は禁止されているんだそうです。

The Geocoding API may only be used in conjunction with a Google map; geocoding results without displaying them on a map is prohibited. For complete details on allowed usage, consult the Maps API Terms of Service License Restrictions.

The Google Geocoding API   |   Google Maps Geocoding API   |   Google Developers

(c) No Mass Downloads or Bulk Feeds of Content. You must not use the Service in a manner that gives you or any other person access to mass downloads or bulk feeds of any Content, including but not limited to numerical latitude or longitude coordinates, imagery, visible map data, or places data (including business listings). For example, you are not permitted to offer a batch geocoding service that uses Content contained in the Maps API(s).

Google Maps/Google Earth APIs Terms of Service   |   Google Maps APIs   |   Google Developers
2015/07/27 15:11:01

コメントはまだありません

この質問への反応(ブックマークコメント)

トラックバック

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません