1417128293 Excelで住所から最寄駅を、一括で検索する方法を探しております。

住所から最寄駅を1つ1つ調べる方法はいろんなページで紹介されていたのですが、一括で数千~数万件のデータを調べる方法は紹介されていないようで。
唯一、

住所 名称から最寄駅等を取得する - ひろボックス ~備忘録~
http://d.hatena.ne.jp/hiroroEX/20131207/1386420196

に秀逸なマクロがあり、実行するとたまに最寄駅や方角・徒歩何分かまでも取得できるのですが、取得できない時もあります。添付画像をご覧いただきたいのですが「m_Return(2) = m_DirectionElements.Item(0).Text」の部分で、マクロが停止します。「実行時エラー91;オブジェクト変数またはWithブロック変数が設定されていません」も出てきます。
マクロのセキュリティレベルや、PC等を変えると、たまに動作して結果を出力してくれるのですが。
ひろボックスさんで紹介されているマクロのコードを変更し、安定して稼働するようにしていただけないでしょうか。
他にも、何か一括で住所から最寄駅を検索する方法(可能でしたら距離等も)がありましたら、お力添えをいただきたいです。住所が難しいようでしたら緯度経度からでも構いません。
よろしくお願いします。

回答の条件
  • 1人10回まで
  • 登録:2014/11/28 07:44:53
  • 終了:2014/12/03 04:52:44

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4506ベストアンサー獲得回数18702014/11/28 09:42:20

ポイント2000pt

最寄り駅を検索する関数 GetListOfNearestStation が間違ってたので、書き直してみました。

'最寄駅を検索するファンクション
'引数  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=")
        Set xhr = CreateObject("MSXML2.XMLHTTP")
        xhr.Open "GET", m_Uri, False
        xhr.Send
            '取得結果を格納
            
            Set elements = xhr.responseXML.DocumentElement
' ★ここから
            Set firstStation = elements.getElementsByTagName("station").Item(0)
            Set child = firstStation.ChildNodes
            
            For i = 0 To child.Length - 1
                
                Select Case child.Item(i).NodeName
                Case "name"
                    m_Return(0) = child.Item(i).Text
                Case "line"
                    m_Return(1) = child.Item(i).Text
                Case "direction"
                    m_Return(2) = child.Item(i).Text
                Case "distance"
                    m_Return(3) = child.Item(i).Text
                Case "traveltime"
                    m_Return(4) = child.Item(i).Text
                End Select

            Next
' ★ここまでを、書き換えてます
            
    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

どこをいじったか分かりやすいように、既に使わなくなった変数も残してます。邪魔なら、消してください。



ちょこっと解説。

駅によって、取得するデータに「方角」に当たる "direction" というデータが入っていない駅があるようです。

住所が「広島県東広島市八本松」の場合には、八本松駅しか検索結果がなく、これに方角のデータがないので、エラーになってました。

<result>
    <station>
        <name>八本松駅</name>
        <furigana>はちほんまつえき</furigana>
        <line>JR山陽本線</line>
        <url>http://map.simpleapi.net/station/hiroshima/hachihonmatsu/</url>
        <city>東広島市</city>
        <prefecture>広島県</prefecture>
        <distance>0</distance>
        <distanceM/>
        <distanceKm/>
        <traveltime>徒歩3分以内</traveltime>
    </station>
</result>

また、住所が「広島県広島市中区胡町」の場合には、検索結果に胡町駅、銀山町駅、八丁堀駅とデータが続くのですが、胡町駅には方角のデータがなく、次の銀山町駅の方角を間違って取得していました。

<result>
    <station>
        <name>胡町駅</name>
        <furigana>えびすちょうえき</furigana>
        <line>広島電鉄[本線]</line>
        <url>http://map.simpleapi.net/station/hiroshima/ebisuchou/</url>
        <city>広島市中区</city>
        <prefecture>広島県</prefecture>
                                            <!-- ※ direction のデータがない -->
        <distance>60</distance>
        <distanceM>60m</distanceM>
        <distanceKm>0.1km</distanceKm>
        <traveltime>徒歩3分以内</traveltime>
    </station>
    <station>
        <name>銀山町駅</name>
        <furigana>かなやまちょうえき</furigana>
        <line>広島電鉄[本線]</line>
        <url>http://map.simpleapi.net/station/hiroshima/kanayamachou/</url>
        <city>広島市中区</city>
        <prefecture>広島県</prefecture>
        <direction></direction>           <!-- ※ こっちを拾ってしまっている -->
        <directionReverse>西</directionReverse>
        <distance>140</distance>
        <distanceM>140m</distanceM>
        <distanceKm>0.1km</distanceKm>
    <traveltime>徒歩2分以上</traveltime>
</station>






追記です。

9000件ぐらいあるので、「For i = 0 To 1000」の部分を「For i = 0 To 9000」にして実行してみたのですが。
どうもうまく取得できませんでして。通常、A2セルからデータを並べれば1000件ぐらいでしたら取得できたりするのですが、数字を変えたりしたからでしょうか、1件も取得できない場合等があります。

ふたつの問題があることが分かりました。

ひとつ目は、Google Geocoding API の制限です。

Google Geocoding API 使用時のクエリ制限として、1 日あたりの位置情報リクエストが 2,500 回に制限されています(Google Maps API for Business をご利用の場合は、1 日あたり 100,000 件までリクエストを実行できます)。

Google Geocoding API - Google Maps API ウェブ サービス — Google Developers

この回数を超えると、位置情報が取得できなくなるので、1件も取得できない、という結果になります。
これは、使う側には、どうしようもないので、制限内の件数で、For ループの開始位置を変えて、複数日に分けて実行するしかありません。

もうひとつは、オブジェクトの開放漏れがあったことです。
ふたつの Web API を使うために MSXML2.XMLHTTP というオブジェクトを使っていますが、こいつの開放がされていません。
環境によって、何件まで取得できるかは変わってくると思いますが、ぼくの環境では 1300件くらいでメモリ不足になりました。

というわけで、見直したソースが以下になります(全てを載せてます)。

Dim xhr

'最寄駅を検索するサンプル
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")

    Set xhr = CreateObject("MSXML2.XMLHTTP")    ' ★一回だけ生成

    'ワークシートから住所を取得
    Worksheets("sheet1").Select
    
    'ワークシートに描画しない
    Application.ScreenUpdating = False
    
    n_not_found = 0
    
    '住所欄を順次取得していく
    For i = 0 To 9000
        '空行なら抜ける
        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)
        
        ' ★3回連続で取得に失敗したら、処理を中断する
        If m_ListOfStation(0) = "" Then
            not_found_count = not_found_count + 1
            If not_found_count > 3 Then
                Exit For
            End If
        Else
            not_found_count = 0
        End If
            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

    Set xhr = Nothing

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=")
'        Set xhr = CreateObject("MSXML2.XMLHTTP")
        xhr.Open "GET", m_Uri, False
        xhr.Send
            '取得結果を格納
            
            Set elements = xhr.responseXML.DocumentElement
            
            If elements.getElementsByTagName("station").Length > 0 Then     ' ★ここを追加
                Set firstStation = elements.getElementsByTagName("station").Item(0)
                
                Set Child = firstStation.ChildNodes
                
                For i = 0 To Child.Length - 1
                    
                    Select Case Child.Item(i).NodeName
                    Case "name"
                        m_Return(0) = Child.Item(i).Text
                    Case "line"
                        m_Return(1) = Child.Item(i).Text
                    Case "direction"
                        m_Return(2) = Child.Item(i).Text
                    Case "distance"
                        m_Return(3) = Child.Item(i).Text
                    Case "traveltime"
                        m_Return(4) = Child.Item(i).Text
                    End Select

                Next        ' ★ここを追加
            End If
            
    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

実は、この回答を書いている時点で、ぼくも Geocoding API の回数制限に引っかかってしまい、動作の確認はできていませんが、多分、2500件までは取得できるはずです。

ぽつぽつ歯抜けがありますが、2519 行目までは処理できました。
データが取得できた住所は 2486 行ありました。
三回連続で最寄り駅を取得できなかった場合には、For ループを中断するようにしてあります。

二日目に入って、また、再開できました。
どうやら回数制限は、引っかかってから 24時間(くらい)経つと解除されるようです。
9000件だと、のんびりやって四日。
テザリングなど、別回線を用意できれば、もっと短縮することができると思います。

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

質問開始時のポイントも十分高額だったのに、お気遣いありがとうございます。
情報共有をふたつほど。


ひとつ目は、元のスクリプトの罠みたいなやつなんですが、住所を参照するセルを指定するのに、このような書き方になってます。

        If (Sheet.Cells(2 + i, 1) = "") Then

Google Geocode API の回数制限がありますから、一日目が 2500 行まで進んだとします。
次の日になって制限が解除されたときに、次の 2501 行目から検索を始めようと思って、ループのカウンタに使ってる i の範囲を、素直に行で 2501 から、と指定して再開すると、2 + i のセルを参照しますから、+2 した行から始まることになり、二行ほどデータの探索を飛ばしてしまうという...

他にデータの抜けが無ければ、検索語の結果を見れば分かるのですが、実際には歯抜けがありますから、後でデータを見ても気が付かない可能性が大きいです。


ふたつ目は、これ。

ぽつぽつ歯抜けがありますが、2519 行目までは処理できました。

データに歯抜けがあることが気になっていました。

例えば、シートの 5014 行目の「滋賀県伊香郡木之本町大字木之本」。
これを指定したときの Geocode API の応答が以下のようになってます。

<GeocodeResponse><status>ZERO_RESULTS</status></GeocodeResponse>

ですが、その住所を Google Map で検索すると、地図では検索できますし、近くにはJR北陸本線の木之本駅があります。
どうやら、これが原因っぽいです。

2010年(平成22年)1月1日 - 東浅井郡虎姫町・湖北町・伊香郡高月町・木之本町・余呉町・西浅井町を編入。人口は大津市と草津市に次ぐ県下第三の都市となった。

長浜市 - Wikipedia

でも、再編だけでこれだけの歯抜けが出るのも、ちょっと解せません。もう少しサンプル。

  • 北海道厚岸郡浜中町大字後静村字姉別市街
    Google Map でも検索できない。
    北海道厚岸郡浜中町 なら OK。
  • 北海道釧路郡釧路町鳥通原野
    「原野」がどうも余計みたいです。鳥通までなら OK 。
  • 秋田県大仙市下鶯野
    Google Map でも見つからない。
    うーん、郵便番号は検索できるのに。
  • 岩手県岩手郡滝沢村大字篠木
    Geocode API では探せているのに、最寄り駅Webサービスでの検索結果が空。
    近くに田沢湖線 大釜駅があるので、最寄り駅Webサービスの問題かと思われる。

んー、ケースバイケースのようです。

2014/12/03 10:37:48
id:moon-fondu

複雑ですね~いろんな要因で歯抜けが出てしまうのは仕方ないですね!
でも大体取得できているので満足です、ありがとうございます(^O^)

2014/12/06 09:41:17

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

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

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

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

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