質問番号：1437189907

人力検索 VBA

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

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

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

よろしくお願い致します。
http://q.hatena.ne.jp/images/question/1437189/1437189907.jpg

Google Maps API V3を使ったプログラムは質問内（http://q.hatena.ne.jp/1437189907）で回答がなされているので、私は別のAPIを利用したプログラムを作成してみました。
住所→緯度経度変換には「Yahoo!ジオコーダAPI（要アプリケーションID)」（Yahoo Maps）、２点間の距離は「距離と方位角の計算API」（測量計算サイト・国土地理院）を利用しました。

http://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/geocoder.html
デベロッパーネットワークトップ > YOLP(地図) > Yahoo!ジオコーダAPI（Yahoo! JAPAN)

http://vldb.gsi.go.jp/sokuchi/surveycalc/api_help.html
測量計算サイト > API使用法 > 距離と方位角の計算（入力パラメータ）

なお、２点間の距離にはヒュベニの公式も利用しています。
サンプルデータについては、冠婚葬祭ネット（寺社一覧）から２万件を抽出しました。

参考サイト

http://www.yahoo-help.jp/app/answers/detail/p/537/a_id/43398
アプリケーションIDを登録する（Yahoo!デベロッパーネットワークヘルプ）

http://veaba.keemoosoft.com/2013/01/474/
住所から緯度経度を取得する（ヴィーバ VeaBa! Excel VBA Tips）

http://tancro.e-central.tv/grandmaster/excel/hubenystandard.html
VBAと測地>Hubenyの式を考察（師匠の散歩）

http://www.touse-web.com/tera/
寺院一覧（冠婚葬祭ネット）

http://www.kyori.jp/setaddr.asp?step=1&fromIdo=no&fromKeido=no&from=no
２点間の直線距離がわかる距離計算サイト（株式会社プロネット）

回答

' 回答プログラム（質問番号：1437189907）
' Author Y.Yoshiya
' Date 2015/07/20

Option Explicit
Option Base 0

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)     'Sleep用
Const YahooAPIKey = ""

Sub main()
 
    Dim Ido1, Keido1 As Single
    Dim Ido2, Keido2 As Single
    Dim IdoKeido As Variant

    Dim MAXROW As Long
    Dim lp As Long
    Dim StartTime, EndTime As Date

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
        MAXROW = .Range("A" & Rows.Count).End(xlUp).Row
        
        If MAXROW < 1 Then
           Exit Sub
        End If
                      
        IdoKeido = GetLocation(.Range("$A$1"))
        Keido1 = IdoKeido(0)
        Ido1 = IdoKeido(1)
        .Range("E1") = Format(Ido1, "0.00000")
        .Range("F1") = Format(Keido1, "0.00000")
        
        For lp = 1 To MAXROW - 1
            IdoKeido = GetLocation(Range("A1").Offset(lp))
            Keido2 = IdoKeido(0)
            Ido2 = IdoKeido(1)
            .Range("E1").Offset(lp) = Format(Ido2, "0.00000")
            .Range("F1").Offset(lp) = Format(Keido2, "0.00000")

            .Range("B1").Offset(lp) = Format(Distance(Ido1, Keido1, Ido2, Keido2) / 1000, "0.000")
            .Range("C1").Offset(lp) = Format(Distance2(Ido1, Keido1, Ido2, Keido2) / 1000, "0.000")

            Call StatusBar(lp, MAXROW - 1)
            Call Sleep(1000)
        Next lp
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)
    
    Application.ScreenUpdating = True
   
End Sub


Private Function Distance(ByVal Ido1 As Single, ByVal Keido1 As Single, ByVal Ido2 As Single, ByVal Keido2 As Single) As Single

    Dim Ido1Rad, Keido1Rad As Single        ' 開始点緯度・経度（ラジアン）
    Dim Ido2Rad, Keido2Rad As Single        ' 終了点緯度・経度（ラジアン）
    Dim P As Single                         ' 2点の平均緯度
    Dim dP As Single                        ' 2点の緯度差
    Dim dR As Single                        ' 2点の経度差
    Dim M As Single                         ' 子午線曲率半径
    Dim N As Single                         ' 卯酉線曲率半径
    Dim Pi As Single                        ' 円周率

    ' ヒュベニの公式
    Pi = Application.WorksheetFunction.Pi()
    Ido1Rad = Ido1 * Pi / 180
    Ido2Rad = Ido2 * Pi / 180
    Keido1Rad = Keido1 * Pi / 180
    Keido2Rad = Keido2 * Pi / 180
    P = (Ido1Rad + Ido2Rad) / 2
    dP = Ido1Rad - Ido2Rad
    dR = Keido1Rad - Keido2Rad
    M = 6334834 / Sqr((1 - 0.006674 * Sin(P) ^ 2) ^ 3)
    N = 6377397 / Sqr(1 - 0.006674 * Sin(P) ^ 2)

    Distance = Sqr((M * dP) ^ 2 + (N * Cos(P) * dR) ^ 2)

End Function


Private Function Distance2(ByVal Ido1 As Single, ByVal Keido1 As Single, ByVal Ido2 As Single, ByVal Keido2 As Single) As Single
    
    Dim URL As String
    Dim xml As Object
    
    Set xml = CreateObject("MSXML2.XMLHTTP")

    ' 国土地理院 測量計算サイト・距離と方位角の計算APIを利用 (http://vldb.gsi.go.jp/sokuchi/surveycalc/api_help.html)
    URL = "http://vldb.gsi.go.jp/sokuchi/surveycalc/surveycalc/bl2st_calc.pl?latitude1=" & Ido1 & "&longitude1=" & Keido1 & "&latitude2=" & Ido2 & "&longitude2=" & Keido2 & "&outputType=xml&ellipsoid=GRS80"

    With xml
        .Open "GET", URL, False
        .send
        With .responseXML
            Distance2 = .getElementsByTagName("geoLength").Item(0).Text
        End With
    End With

    Set xml = Nothing

End Function


Private Function GetLocation(ByVal Address As String) As Variant

    Dim URL As String
    Dim xml As Object
    
    Set xml = CreateObject("MSXML2.XMLHTTP")

    If Not IsEmpty(Address) Then
        Address = AscEx(Address)
        URL = "http://geo.search.olp.yahooapis.jp/OpenLocalPlatform/V1/geoCoder?appid=" & YahooAPIKey & "&query=" & EncodeURI(Address) & "&al=3&ar=le&recursive=true"
        
        With xml
            .Open "GET", URL, False
            .send
            With .responseXML
                If .getElementsByTagName("Count").Item(0).Text > 0 Then
                    GetLocation = Split(.getElementsByTagName("Coordinates").Item(0).Text, ",")
                End If
            End With
        End With
    End If
    
    Set xml = Nothing
 
End Function


Private Function EncodeURI(ByVal argString As String) As String

    argString = Replace(Replace(argString, "\", "\\"), "'", "\'")
    
    With CreateObject("HtmlFile")
        .parentWindow.execScript "document.write(encodeURIComponent('" & argString & "'));", "JScript"
        EncodeURI = .Body.innerHTML
    End With

End Function


Private Function StatusBar(Bunshi As Long, Bunbo As Long)

    Dim lp As Long
    Dim Parcent As Single
    Dim BarCount As Integer

    Application.StatusBar = True
    Parcent = (Bunshi / Bunbo) * 100
    BarCount = Int(Parcent / 5)
    DoEvents
    Application.StatusBar = "処理中..." & Format(Parcent, "0.00") & "%" & String(BarCount, "■")

End Function


Private Function AscEx(strOrg As String) As String

    Dim strRet As String
    Dim lp As Integer
    Dim strChar As String
    
    strRet = ""
    
    For lp = 1 To Len(strOrg)
        strChar = Mid(strOrg, lp, 1)
        
        If (strChar >= "０" And strChar <= "９") Or (strChar >= "Ａ" And strChar <= "Ｚ") Or (strChar >= "ａ" And strChar <= "ｚ") Then
            strRet = strRet & StrConv(strChar, vbNarrow)
        Else
            strRet = strRet & strChar
        End If
    Next lp
   
    AscEx = strRet

End Function

出力結果

B列はヒュベニの公式で計算した距離、C列は距離と方位角の計算API(測量計算サイト)を利用した距離

追記

地図の表示を伴わないGoogle Geocoding API単独での利用は利用規約で禁止されているそうです。
また、Google MAPS APIの利用制限については、最大2500回/１日です。

参考サイト

http://syncer.jp/how-to-use-geocoding-api
ジオコーディングと逆ジオコーディングをする方法(Google Geocoding APIの使い方)

1日のリクエスト回数
Google Geocoding APIは、API KEYを用いずに、気軽に利用できるAPIですが、1日あたりのリクエスト数に厳しめの上限回数が設定されています。一般ユーザーは2,500回、ビジネスユーザーは100,000回となっています。

Google Mapsとの組み合わせが必要
このGeocoding APIで取得したデータは、Google Mapsに反映させる目的でのみ、使用が許可されています。必ず、同ページにGoogle Mapsの地図を表示するようにしましょう。下記は注意書きの引用です。

Geocoding API は Google マップ上の結果表示と組み合わせる場合にのみ使用できます。地図に表示せずにジオコーディングの結果だけを利用することは禁止されています。許可されている使用方法の詳細については、Maps API 利用規約のライセンス制限をご覧ください。

原文（サービス > Google Maps APIs > Google Maps API Web Services > Google Maps Geocoding 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.

Yahoo!が提供しているWeb APIの利用制限についてですが、１アプリケーションIDにつき最大50000回／1日だそうです。
1ユーザーで最大１０個のアプリケーションIDが取得できるそうなので、最大利用すると1日に500000回までWEB APIが利用できそうです。

デベロッパーネットワークトップ > 開発のヒント > 利用制限について（Yahoo! JAPAN）

https://app.box.com/s/zetrz21f02dl0bsb8bicdvxihe1kxbah