住所 名称から最寄駅等を取得する
下記のサイトのコードを少し変えて
シートにある住所から最寄駅等の情報を作ってみました。
住所から最寄駅を検索する | ヴィーバ VeaBa! Excel VBA Tips
http://veaba.keemoosoft.com/2013/02/488/
コードを読むのに時間かかりました。。。
変更したのは直近の一件のみ取得と
シートから住所取り込んで情報を入れる部分だけです。
SimpleAPI「最寄り駅Webサービス」
で緯度、経度から最寄駅、路線情報、距離、時間取得できる便利な
サービスと
緯度経度は
Google Geocoding APIを使って、検索して渡して上記の情報を
取得してくるというもの。
と参照設定でXML扱えるように
下記サイトを参考
http://d.hatena.ne.jp/end0tknr/20081115/1226755041
'最寄駅を検索するサンプル Sub Sample_search_near_station() Dim i As Integer Dim m_ListOfStation() As String Dim address As String Dim Sheet As Object 'Excel.Worksheet Set Sheet = Worksheets("sheet1") 'ワークシートから住所を取得 Worksheets("sheet1").Select 'ワークシートに描画しない Application.ScreenUpdating = False '住所欄を順次取得していく For i = 0 To 1000 '空行なら抜ける If (Sheet.Cells(2 + i, 1) = "") Then Exit For Else address = Sheet.Cells(2 + i, 1).Value '最寄駅を検索するサブプロシージャの呼び出し m_ListOfStation = GetListOfNearestStation(GetLocation(address)) 'UBOUND関数配列の名前を指定する 'For j = 0 To (UBound(m_ListOfStation) / 5 - 1) Sheet.Cells(2 + i, 2) = m_ListOfStation(0) Sheet.Cells(2 + i, 3) = m_ListOfStation(1) Sheet.Cells(2 + i, 4) = m_ListOfStation(2) Sheet.Cells(2 + i, 5) = m_ListOfStation(3) Sheet.Cells(2 + i, 6) = m_ListOfStation(4) 'Next End If 'DoEventsの実行 ' DoEvents Next '結果を描画する Application.ScreenUpdating = True End Sub '最寄駅を検索するファンクション '引数 ByRef参照渡し ' 検索する建物名 Private Function GetListOfNearestStation(ByRef argLocation As String) As String() Dim m_Return(5) As String Dim m_Uri As String Dim m_NameElements As Object Dim m_LineElements As Object Dim m_DirectionElements As Object Dim m_DistanceElements As Object Dim m_TraveltimeElements As Object Dim i As Integer '住所入っていた場合 If Len(argLocation) > 0 Then 'SimpleAPI「最寄り駅Webサービスを利用 '緯度 経度を指定して最寄駅を検索 m_Uri = "http://map.simpleapi.net/stationapi?output=xml&y=" & _ Replace(argLocation, ",", "&x=") ' With CreateObject("MSXML2.XMLHTTP") ' .Open "GET", m_Uri, False: .Send ' With .responseXML Set xhr = CreateObject("MSXML2.XMLHTTP") xhr.Open "GET", m_Uri, False xhr.Send '取得結果を格納 Set elements = xhr.responseXML.DocumentElement Set m_NameElements = elements.getElementsByTagName("name") Set m_LineElements = elements.getElementsByTagName("line") Set m_DirectionElements = elements.getElementsByTagName("direction") Set m_DistanceElements = elements.getElementsByTagName("distance") Set m_TraveltimeElements = elements.getElementsByTagName("traveltime") 'Debug.Print m_NameElements(0).Text If m_NameElements.Length > 0 Then 'ReDim m_Return(m_NameElements.Length, 5) '検索結果すべて表示する場合 ' For i = 1 To m_NameElements.Length ' '駅名の取得 ' m_Return(i, 1) = m_NameElements.Item(i - 1).Text ' '路線名の取得 ' m_Return(i, 2) = m_LineElements.Item(i - 1).Text ' '方角の取得 ' m_Return(i, 3) = m_DirectionElements.Item(i - 1).Text ' '駅までの距離を取得 ' m_Return(i, 4) = m_DistanceElements.Item(i - 1).Text ' '駅までにかかる時間の取得 ' m_Return(i, 5) = m_TraveltimeElements.Item(i - 1).Text ' Next '一番の最寄駅だけ取得 m_Return(0) = m_NameElements.Item(0).Text '路線名の取得 m_Return(1) = m_LineElements.Item(0).Text '方角の取得 m_Return(2) = m_DirectionElements.Item(0).Text '駅までの距離を取得 m_Return(3) = m_DistanceElements.Item(0).Text '駅までにかかる時間の取得 m_Return(4) = m_TraveltimeElements.Item(0).Text Else 'Redim 動的配列 'ReDim m_Return(0) End If 'End With 'End With Else 'ReDim m_Return(0) End If GetListOfNearestStation = m_Return 'オブジェクトの破棄処理 Set m_DirectionElements = Nothing Set m_LineElements = Nothing Set m_DirectionElements = Nothing Set m_DistanceElements = Nothing Set m_TraveltimeElements = Nothing End Function '緯度 経度を取得するファンクション '引数 検索する建物 Public Function GetLocation(ByRef argAddressString As String) As String Dim m_Uri As String 'Debug.Print argAddressString If Len(argAddressString) > 0 Then m_Uri = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & _ EncodeURI(argAddressString) & "&sensor=false" 'With CreateObject("MSXML2.XMLHTTP") ' .Open "GET", m_Uri, False: .Send ' '分割して記述した例が下 Set xhr = CreateObject("MSXML2.XMLHTTP") xhr.Open "GET", m_Uri, False xhr.Send 'Debug.Print m_Uri 'With CreateObject("MSXML2.XMLHTTP").responseXML '取得結果を格納 Set elements = xhr.responseXML.DocumentElement '情報を取得できたら格納 If elements.getElementsByTagName("status").Item(0).Text = "OK" Then 'locationタグの読み込み '緯度経度間の空白を,に置換 '置換例 35.7100327,139.8107155 GetLocation = Replace(elements.getElementsByTagName("location").Item(0).Text, " ", ",") End If 'End With 'End With End If End Function 'URLエンコードを行うファンクション 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
イメージは下記。