【Excel VBA】「Yahoo路線情報」の乗り換え案内を使って、複数分の移動時間・運賃を一括検索する - 変換.tokyo | henkan.tokyo

【Excel VBA】「Yahoo路線情報」の乗り換え案内を使って、複数分の移動時間・運賃を一括検索する

 
■【Excel VBA】「Yahoo路線情報」の乗り換え案内から、複数分の移動時間・運賃を一括検索する

例えばオフィスを移転するような場合、人事の担当者は、スタッフの交通費がどれくらい増減するのか等を気にすると思います。
そこで「Yahoo路線情報」の乗り換え案内の情報を自動的に取得、複数名分の移動時間・運賃を一括で検索し、リスト表示するというExcel VBAをご紹介致します。

今回、こちらのWebサイト「VBA(マクロ)で仕事を楽しく効率化」の情報を参考にさせていただきました。
http://officevba.info/norikaevba/



■VBAの動作

プログラムの基本的な流れは以下の通りです。
@InternetExplorerを開く
A「Yahoo路線情報」のページ(http://transit.yahoo.co.jp/)に移動する
B出発地・目的地・時間・その他新幹線を使用するか、特急を使用するかなどの条件を入力(〇印を付ける)する
C「Yahoo乗換案内で検索」ボタンをクリックする
D表示されたページから必要な情報を収集し、Excelシートに転記する
E上記A〜Dを繰り返す
FInternetExplorerを終了する



■サンプルコード

Option Explicit
Dim colSh As Object
Dim win As Object
Dim strTemp As String
Dim IE As InternetExplorer
Dim objIE(5) As InternetExplorer
Dim objIE2 As InternetExplorer
Dim txtInput(16) As HTMLInputElement
Dim txtInput2(20) As HTMLSelectElement
Dim button(10) As HTMLInputElement
Dim Form
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub 集計()
Dim x As Long
IE立ち上げ
x = 4
Do Until x > Cells(60000, 3).End(xlUp).Row
乗り換え案内検索 (x)
乗り換え案内結果集計 (x)
IE繰り返し
x = x + 1
Loop
IE終了
End Sub

Private Sub IE立ち上げ()
'@InternetExplorerを開く
Set IE = CreateObject("InternetExplorer.application")
IE.Visible = True
'AYahoo乗り換え検索のページ("http://transit.yahoo.co.jp/")に移動
IE.navigate ("http://transit.yahoo.co.jp/")
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Private Sub 乗り換え案内検索(i As Long)
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
If InStr(win.document.Title, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'B出発地・目的地・時間・その他新幹線を使用するか、特急を使用するかなどの条件入力
'B-1 出発地の入力
Set txtInput(1) = objIE(0).document.getElementById("sfrom")
txtInput(1).Value = Cells(i, 3).Value
'B-2 到着地の入力
Set txtInput(2) = objIE(0).document.getElementById("sto")
txtInput(2).Value = Cells(i, 4).Value
'B-3 新幹線を利用するか
Set txtInput(3) = objIE(0).document.getElementById("sexp")
If Cells(i, 8).Value = "○" Then
txtInput(3).Checked = True
Else
txtInput(3).Checked = False
End If
'B-4 有料特急を利用するか
Set txtInput(4) = objIE(0).document.getElementById("exp")
If Cells(i, 9).Value = "○" Then
txtInput(4).Checked = True
Else
txtInput(4).Checked = False
End If
'B-5 出発時間での検索
Set txtInput(5) = objIE(0).document.getElementById("tsDep")
If Cells(i, 5).Value = "出発" Then
txtInput(5).Checked = True
End If
'B-6 到着時間での検索
Set txtInput(6) = objIE(0).document.getElementById("tsArr")
If Cells(i, 5).Value = "到着" Then
txtInput(6).Checked = True
End If
'B-7 日時の入力
Set txtInput2(0) = objIE(0).document.getElementById("y")
txtInput2(0).Value = Year(Cells(i, 6))
Set txtInput2(1) = objIE(0).document.getElementById("m")
txtInput2(1).Value = Format(Month(Cells(i, 6)), "00")
Set txtInput2(2) = objIE(0).document.getElementById("d")
txtInput2(2).Value = Format(Day(Cells(i, 6)), "00")
Set txtInput2(3) = objIE(0).document.getElementById("hh")
txtInput2(3).Value = Format(Hour(Cells(i, 7)), "00")
Set txtInput2(4) = objIE(0).document.getElementById("mm")
txtInput2(4).Value = Format(Minute(Cells(i, 7)), "00")
'B-8 検索結果表示順の選択
Set txtInput2(5) = objIE(0).document.getElementsByName("s")(0)
If Cells(i, 10).Value = "到着が早い順" Then
txtInput2(5).Value = "0"
ElseIf Cells(i, 10).Value = "乗り換え回数順" Then
txtInput2(5).Value = "2"
ElseIf Cells(i, 10).Value = "料金が安い順" Then
txtInput2(5).Value = "1"
End If
'C検索ボタンをクリック
Set Form = objIE(0).document.getElementById("searchModuleSubmit")
Form.Click
Sleep 1000
Do While objIE(0).Busy Or objIE(0).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Sub 乗り換え案内結果集計(i As Long)
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
If InStr(win.document.Title, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'D表示されたページから必要な情報を収集
Set txtInput(7) = objIE(0).document.getElementsByClassName("small")(0)
Cells(i, 11).Value = txtInput(7).innerText
Cells(i, 11).Value = Replace(Replace(Cells(i, 11), "(", ""), ")", "")
Set txtInput(8) = objIE(0).document.getElementsByClassName("small")(1)
Cells(i, 13).Value = txtInput(8).innerText
Cells(i, 13).Value = Replace(Replace(Cells(i, 13), "(", ""), ")", "")
Set txtInput(9) = objIE(0).document.getElementsByClassName("small")(2)
Cells(i, 15).Value = txtInput(9).innerText
Cells(i, 15).Value = Replace(Replace(Cells(i, 15), "(", ""), ")", "")
Set txtInput(10) = objIE(0).document.getElementsByClassName("fare")(0)
Cells(i, 12).Value = txtInput(10).innerText
Set txtInput(11) = objIE(0).document.getElementsByClassName("fare")(1)
Cells(i, 14).Value = txtInput(11).innerText
Set txtInput(12) = objIE(0).document.getElementsByClassName("fare")(2)
Cells(i, 16).Value = txtInput(12).innerText
End Sub

Private Sub IE繰り返し()
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
strTemp = win.document.body.innerText
If InStr(strTemp, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'E-1 Yahoo乗り換え検索のページ("http://transit.yahoo.co.jp/")に移動
objIE(0).navigate ("http://transit.yahoo.co.jp/")
Sleep 1000
Do While objIE(0).Busy Or objIE(0).readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Private Sub IE終了()
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
strTemp = win.document.body.innerText
If InStr(strTemp, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'FInternetExplorerを終了
objIE(0).Quit
End Sub


■サンプルVBAダウンロード
こちらから

■VBAからIEを操作するのに参考となる図書




by カエレバ
by カエレバ
by カエレバ
by カエレバ
by カエレバ
by カエレバ