なんかグーグルのapiいきなり支払いとか英語できそうで怖い(先入観)からヤフーのAPI使うよ(笑)
developer.yahoo.co.jp
なんかアプリケーション作るとClient IDってのが発行されるのでどっかにコピペしておきましょう。
API使うときに「アプリケーションID」とか急に出てくるのでソレがコレでした。焦ったw
住所→緯度経度を出す→2点間の距離を出す というステップです。
実行イメージ
エラーの処理が怪しい。変な住所入れると止まるかもw
Option Explicit Public ClientID As String Sub mein() ClientID = "XXXX" Dim r As Integer Dim strData r = 2 '緯度経度セット Do Until Cells(r, 2) = "" Range(Cells(r, 3), Cells(r, 4)).ClearContents If ActiveSheet.Cells(r, 2).Value <> "" Then strData = Split(緯度経度取得(ActiveSheet.Cells(r, 2).Value), ",") ActiveSheet.Cells(r, 3).Value = Val(strData(0)) '緯度 ActiveSheet.Cells(r, 4).Value = Val(strData(1)) '経度 End If r = r + 1 Loop r = 3 '2点間距離 Do Until Cells(r, 2) = "" Dim distance As String: distance = 距離取得(Range("C2"), Range("D2"), Cells(r, 3), Cells(r, 4)) Cells(r, 5) = distance r = r + 1 Loop End Sub Function 緯度経度取得(ByVal adress As String) As String Dim ret Dim retStr As String Dim URL As String adress = WorksheetFunction.EncodeURL(adress) URL = "https://map.yahooapis.jp/geocode/V1/geoCoder?appid=" & ClientID & "&query=" & adress ret = WorksheetFunction.WebService(URL) If WorksheetFunction.FilterXML(ret, "//ResultInfo/Count") <> "0" Then 緯度経度取得 = WorksheetFunction.FilterXML(ret, "//Feature[1]/Geometry/Coordinates") Else 緯度経度取得 = "取得不能,取得不能" End If End Function Function 距離取得(ido1 As Double, keido1 As Double, ido2 As Double, keido2 As Double) As String Dim coordinates As String: coordinates = ido1 & "," & keido1 & " " & ido2 & "," & keido2 Dim URL As String: URL = "https://map.yahooapis.jp/dist/V1/distance?appid=" & ClientID & "&coordinates=" & coordinates Dim ret: ret = WorksheetFunction.WebService(URL) If WorksheetFunction.FilterXML(ret, "//ResultInfo/Count") <> "0" Then 距離取得 = WorksheetFunction.FilterXML(ret, "//Feature[1]/Geometry/Distance") Else 距離取得 = "取得不能" End If End Function