エクセルに出発駅・到着駅を入力して自動で交通費を出したい。
昨日以降(0) 2日前以降(0) 3日前以降(0) 4日前以降(0) 5日前以降(0)
Message#1 2014年10月23日(木)20時03分 From: 地図地図 | 返事 削除 変更 |
エクセルに出発駅・到着駅を入力して自動で交通費を出したい。 vba自体も初心者なもので、合っているかどうかも分かりません。 出来れば画像の表が決められた様式なのでそちらに合うように作成したいのですが、どなたか良いお知恵を頂けないでしょうか。 宜しくお願い致します!! (補足)別のシートにて試験的に作成してみたvbaですが、取得失敗してしまいます。 またyahoo路線の「きっぷ優先」で検索をしたい形なのですが、どのようにしたら良いか分かりません・・。 A1:大阪 A2:名古屋 A3:6,180円 ボタンも作成してみました。 Private Sub CommandButton1_Click() Call GetFareTest1 End Sub '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.loco.yahoo.co.jp/" sST = Encode_Uni2UTF(Range("A1").Value) sDST = Encode_Uni2UTF(Range("A2").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("A3").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 |
昨日以降 2日前以降 3日前以降 4日前以降 5日前以降