excle VBA とweb上の検索を利用して出発駅から到着駅まで所要時間と運賃を出したいです。

Question

Excelとweb上をつなげて以下のようなことができればと考えております。

A列に出発駅
B列に到着駅
C列に運賃
D列に所要時間

以下の質問に似たような質問があり、コピペしてみたのすが、「取得に失敗」
とでるだけでうまくいきません。

過去の質問のURLも載せておきます。
どなたかお詳しい方ご教授頂ければ幸いです。

ttps://oshiete.goo.ne.jp/qa/5258945.html?from=recommend
↓
ｈをわざと抜いています。（はじかれないようにです。）

質問の中の
プログラムは以下です。
（列の指示のみ変更しています）

なにがダメなのかもわからない、ずぶの素人です。
ご教授のほどよろしくお願い致します。

'-------------------------------------------
'標準モジュール
'-------------------------------------------
'Option Explicit

Sub GetFareTest1()
　　Dim IE As Object
　　Dim myURL As String
　　Dim myContent As String
　　Dim buf As String
　　Dim sST As String
　　Dim sDST As String
　　'ヤフー運賃検索(Yahoo!路線情報)
　　myURL = "http://transit.map.yahoo.co.jp"
　　
　　sST = Encode_Uni2UTF(Range("A２").Value)
　　sDST = Encode_Uni2UTF(Range("B2").Value)
　　If sST = "" Or sDST = "" Then MsgBox "セルに文字がありません。", 48: Exit Sub
　　myURL = myURL & "/search/result?from=" & sST & "&to=" & sDST
　　
　　Set IE = CreateObject("InternetExplorer.Application")
　　With IE
　　　　'.Visible = True 　'コメントブロックをしたら、表示する
　　　　.Navigate myURL
　　　　Do While .Busy
　　　　　　DoEvents
　　　　Loop
　　　　Do Until .ReadyState = 4
　　　　　　DoEvents
　　　　Loop
　　　　myContent = .Document.body.innerHTML
　　　　'情報が取れなくなったときは、ここでログを取る
　　　　.Quit
　　End With
　　Set IE = Nothing
　　
　　'出力
　　Range("C3").Value = PickUpString(myContent, "片道")
End Sub
Function PickUpString(ByVal strContent As String, SearchTxt As String)
Dim buf As String
Dim i As Long
Dim j As Long
　buf = Mid$(strContent, InStr(1, strContent, SearchTxt, 1) + 2, 40)
　　 i = InStr(1, buf, ">", 1) + 1
　　 j = InStrRev(buf, "</S", , 1)
　　 If i * j > 0 Then
　　 PickUpString = Mid$(buf, i, j - i)
　　 Else
　　 PickUpString = "取得に失敗"
　　 End If
End Function

'-------------------------------------------
Private Function Encode_Uni2UTF(ByRef strUni As String)
Dim buf As Variant
Dim tbuf As Variant
Dim n As Variant
Const CSET = "UTF-8"
Const ADTYPETEXT = 2
Const ADTYPEBINARY = 1
Dim ADOstrm As Object 'ADODB.Stream

　　On Error GoTo ErrHandler
　　Set ADOstrm = CreateObject("ADODB.Stream")　'New ADODB.Stream
　　ADOstrm.Open
　　ADOstrm.Type = ADTYPETEXT
　　ADOstrm.Charset = CSET
　　ADOstrm.WriteText strUni
　　ADOstrm.Position = 0
　　ADOstrm.Type = ADTYPEBINARY
　　ADOstrm.Position = 3
　　buf = ADOstrm.Read()
　　ADOstrm.Close
　　Set ADOstrm = Nothing
　
　　For Each n In buf
　　　 tbuf = tbuf & "%" & Hex(n)
　　Next
　　Encode_Uni2UTF = tbuf
　　Exit Function
ErrHandler:
　　If ADOstrm Is Nothing = False Then ADOstrm.Close
　　Set ADOstrm = Nothing
End Function

WindFaller · Accepted Answer

こんにちは。

[03:38] 身体を壊さないようにしてくださいね。

私は、不眠症で、通常は睡眠時間5時間以内ですが、こういうWeb開発をする時は、どんなに大きなものでも、徹夜で一気につくってしまいます。

もちろん、今回のは、一番簡単なWeb開発の基本ですから、長い時間は不要です。
（なお、開発におけるアクセス数は、極力増やさないように、せいぜい3回程度です。）

>例えば「結果の一番最初の運賃と所要時間のみを抽出すること」も可能ということでしょうか。

簡単です。

With objIE
    j = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Set oFrom = .document.getElementById("sfrom")
    oFrom.Value = Cells(j, 1).Value
    Set oSt = .document.getElementById("sto")
    oSt.Value = Cells(j, 2).Value
    Set btnSrch = .document.getElementById("searchModuleSubmit")
    btnSrch.Click
  End With
  Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop
  With objIE
    Set oFare = .document.getElementsByClassName("fare")
    Set oSmal = .document.getElementsByClassName("small")
    'For i = 0 To oSmal.Length - 1
      Cells(j, 3).Value = oFare(0).innerText
      Cells(j, 4).Value = oSmal(0).innerText
    'Next
  End With
  objIE.Quit

とクリック一回事なら、こうすればよいです。

>Ａ列Ｂ列に１００件ほどの出発駅と到着駅を並べ、調べたい場合は今は"A2"と"B2"としている部分を変更することで対応可能なものでしょうか。

これは、もし連続で取得するとなると、ちょっと事情が変わってきます。

つたないながらも、経験があるので、あえてネガティブなことを言うのですが、プログラムとしては、別のワザが必要になってしまいます。いちいち、Navigate でアクセスしていたら、いろんな負担が、増大してしまいます。また、数が多くなると、Web側の判定できないメッセージやエラー対策も必要になってきます。

しかし、それ以上に、自主規制が必要になるかもしれません。

昔、ハローワークの仕事探しの検索の時と同じルールを適用したほうがよいかもしれません。ハローワークはスクレイピング禁止ですが方法があります。相手のサーバーの負荷や迷惑を考えなくてはなりませんので、1分間に、60回は越えてはいけないとか、『自主規制』を設けないといけなくなります。ハローワークの人によるアクセスは、半端ではありませんが。

そこで、VBAのWait というコマンドの代わりに、Sleep というWin API関数を用いて、プログラムに負荷(weight?)を掛けます。

実際は、このプログラムは、スクレイピングともクローリングとも呼ばないのですが、ロボット収集として、相手サーバーからは目をつけられやすい、負担が増えると、相手側がチェックして、IPアドレスは記録されることは覚悟しなければなりません。NTT回線では、関西のほうが厳しかったと思います。

Yahooでは、ネットの専門の会社ですから、非常識なことはしませんが、最近でも、朝早く警察がいきなりやってきて、証拠もなしに自白を強要されたり、認めなければ、数週間にも渡る留置・勾留というものもあります。コードを見れば一目瞭然だと分かるはずなのに、それでも、警察は信用してくれないのです。何年たっても警察組織は、それを改める様子が見られないということです。

データを取得した後に気をつけること
一応のお約束としては、データは、個人で使い商用では用いないこと。
公開されている規約があれば、それに従うこと。

Webスクレイピングの注意事項一覧
https://qiita.com/nezuq/items/c5e827e1827e7cb29011#%E3%81%AF%E3%81%98%E3%82%81%E3%81%AB

今更ながら、元のコードを発表した頃は良かったですね。

今回の修正コードで、単発取得の場合

WindFaller · Answer

こんばんは。そう言えば、私もこれ作っていますね。Yahooの画面をみて思い出しました。元のコードの頃は、そういう書き方が主流だったというしかありませんね。 #2さんのご指摘はそのものズバリですが、私も、もう一度、見直す時期が来ているような気がします。一応、地名は駅名にしてくださいね。名称の最後に駅がとつくので、「東京駅」「名古屋駅」とかします。IE は、Visible を立てませんので、エラーの時は、IEが潜ってしまうことがあります。その場合は、タスクマネージャーで消してください。本来は、Errorトラップを置くべきかもしれません。とても簡単な内容ですから、参考にしてみてください。今は、選択肢が多すぎることを予想していません。あまり多くを試したわけではありませんし、以前は、経由とか時間まで入れた記憶があります。しばらく様子をみてください。 '// Sub GetFareTest2() 　'事前バインディングで、Internet Control を参照設定しておきます。　Dim objIE As SHDocVw.InternetExplorer 　Dim i As Long, j As Long 　Dim oSt, oFrom, btnSrch, oFare, oSmal 　Set objIE = New SHDocVw.InternetExplorer 　If Range("A2").Value = "" Or Range("B2").Value = "" Then Exit Sub 　If Not (Range("A2").Value Like "*駅" And Range("B2").Value Like "*駅") Then 　　MsgBox "駅名を入れたください。", vbExclamation 　　Exit Sub 　End If 　objIE.Navigate2 "https://transit.yahoo.co.jp/" 　Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop 　　With objIE 　　Set oFrom = .document.getElementById("sfrom") 　　oFrom.Value = Range("A2").Value 　　Set oSt = .document.getElementById("sto") 　　oSt.Value = Range("B2").Value 　　Set btnSrch = .document.getElementById("searchModuleSubmit") 　　btnSrch.Click 　End With 　Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop 　j = Cells(Rows.Count, 1).End(xlUp).Row 　With objIE 　　Set oFare = .document.getElementsByClassName("fare") 　　Set oSmal = .document.getElementsByClassName("small") 　　For i = 0 To oSmal.Length - 1 　　　Cells(i + j, 3).Value = oFare(i).innerText 　　　Cells(i + j, 4).Value = oSmal(i).innerText 　　Next 　End With 　objIE.Quit 　Set objIE = Nothing End Sub

fujillin · Answer

こんにちは

参考になさった過去の質問を見ればわかると思いますが、web上のサービス（具体的にはYahooの路線と運賃の検索）をそのまま利用して表示しているだけのものです。

＞「取得に失敗」とでるだけでうまくいきません。
今現在、http://transit.map.yahoo.co.jp にアクセスしてみればわかると思いますが、当時のサービスは終了しているようです。
（元の質問は2009年なので…。他で継続しているのかも知れませんが、少なくともアドレスは変わっています。）
それなので、検索以前に指定サイトにリクエストを送っても結果が表示されないので、「取得に失敗」ということになっているのでしょう。