VBAやadd-inによる交通費自動計算（エクセル

質問

ExcelのA列に出発地、B列に目的地、Ｃ列に経由地を入力することD列に運賃が自動表示されるようにしたいと考えています。
※元データがＤ列がブランクで、6,000行程のデータがあるため、一つ一つ検索をするのは時間がかかるため

VBAの場合、以下２つを参照しましたが、正常に動きませんでした。
http://okwave.jp/qa/q5258945.html
http://okwave.jp/qa/q1641060.html

add-inの場合、「お自動君」というものがあるのですが、現在閉鎖されているようでダウンロードができません。
http://www.popxpop.com/archives/2007/03/post_144.html

「お自動君」のような形式が理想なのですが、
他に良いadd-inか、VBAでの処理方法があれば教えて頂けますでしょうか？

回答No.3

DOUGLAS_

＞「お自動君」のような形式が理想なのですが、
＞現在閉鎖されているようでダウンロードができません。
とのことですので、マクロを書いてみました。

●交通費の精算を自動化するエクセルのアドイン『お自動君』
http://www.popxpop.com/archives/2007/03/post_144.html
に例示された表
http://www.popxpop.com/archives/2007/03/01/xsl24.gif
と同様に、「出発地」・「到着地」・「往復」のデータが入っているセルの右側を選択して、マクロを実行すると、そのセルに運賃の計算結果が入力され、そのセルをクリックすると、計算の元になった「Yahoo! 運賃探索」のページが開くようにしてあります。

　セル範囲は複数行指定できますので、料金を入力すべきセル範囲を選択して、getFare を実行してみてください。
　また、「往復」の欄は「空欄でない場合」を往復とみなすようにしてあります。

　上記の例表と同様の値を入力して、getFare を実行したのが、添付画像です（原因が分かりませんが、３行目と９行目は計算結果が異なりました）。

　なお、運賃探索に用いたURLには、「出発地」・「到着地」の他は
利用設定:新幹線を使う(shin=1)
利用設定:有料列車を使う(ex=1)
探索方法:指定なし(type=5)
しか設定しておりません。

'------------------------------------
Option Explicit
Sub getFare()
　 Dim objHTTP As Object　　　'WinHttpRequest オブジェクト
　 Dim myRng As Range　　　　 '選択範囲
　 Dim sstart As String　　　 '出発地
　 Dim sto As String　　　　　'到着地
　 Dim isRT As Boolean　　　　'往復かどうか
　 Dim strURL As String 　　　'検索URL
　 Dim strRes As String　　　 'html ソース

　 Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　 For Each myRng In Selection
　　　sstart = myRng.Offset(, -3).Value
　　　sto = myRng.Offset(, -2).Value
　　　isRT = IIf(myRng.Offset(, -1).Value = "", False, True)
　　　strURL = "http://transit.loco.yahoo.co.jp/search/result?from=" & UrlEncodeUtf8(sstart) & _
　　　　 "&to=" & UrlEncodeUtf8(sto) & "&shin=1&ex=1&type=5"
　　　With objHTTP
　　　　 .Open "GET", strURL, False
　　　　 .Send
　　　　 If .Status = 200 Then strRes = .ResponseText
　　　End With
　　　strRes = Split(Mid(strRes, InStr(strRes, "片道")), ">")(1)
　　　strRes = Left(strRes, InStr(strRes, "円") - 1)
　　　myRng.Formula = "=HYPERLINK(""" & strURL & """," & strRes * IIf(isRT, 2, 1) & ")"
　 Next
　 Set objHTTP = Nothing
End Sub

'参照）http://komet163.blog36.fc2.com/blog-entry-18.html
'UrlEncodeUtf8: 文字列をUTF-8でエンコードするFunction
Public Function UrlEncodeUtf8(ByVal strSource As String) As String
　 Dim objSC As Object
　 Set objSC = CreateObject("ScriptControl")
　 objSC.Language = "Jscript"
　 UrlEncodeUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
　 Set objSC = Nothing
End Function

回答No.2

K Kazz（@JazzCorp）

検索パラメータが変更になっており、元のままだと、在来線の普通料金が出る。新幹線の大阪-東京の場合、現在のWebでは、これが検索結果のURL、
http://transit.loco.yahoo.co.jp/search/result?flatlon=&from=%E5%A4%A7%E9%98%AA&tlatlon=&to=%E6%9D%B1%E4%BA%AC&via=&shin=1&expkind=1&ym=201212&d=04&datepicker=&hh=14&m1=0&m2=1&type=1&ws=2&s=0&x=103&y=33&kw=%E6%9D%B1%E4%BA%AC
VBAで合成している最終的なURL：
http://transit.loco.yahoo.co.jp/search/result?from=%E5%A4%A7%E9%98%AA&to=%E6%9D%B1%E4%BA%AC
を、こうすると、新幹線の普通＋特急（普通車）料金が出る。
http://transit.loco.yahoo.co.jp/search/result?&shin=1&expkind=1&from=%E5%A4%A7%E9%98%AA&to=%E6%9D%B1%E4%BA%AC
shin=1、expkind=1、以外のその他のパラメータの機能は不明
解かる範囲で（勝手に！）直してみたのが、これ、

Option Explicit
Sub FareLoco()
Const myYahoo = "http://transit.loco.yahoo.co.jp"
Const xHead = "出発地,目的地,経由地,片道"
Const xHeads = 1
Dim xLast As Long
Dim nn As Long
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!路線情報)
'Cells(1, "A").resize(1,4)=split(xHead,",")
xLast = Cells(Rows.Count, "A").End(xlUp).Row
For nn = xHeads + 1 To xLast
If (Cells(nn, "A").Value <> Empty) And (Cells(nn, "B").Value <> Empty) Then
sST = Encode_Uni2UTF(Cells(nn, "A").Value)
sDST = Encode_Uni2UTF(Cells(nn, "B").Value)
If (sST = "" Or sDST = "") Then MsgBox "セルに文字がありません。", 48: Exit Sub

'myURL = myYahoo & "/search/result?from=" & sST & "&to=" & sDST
'shin=1を指定しないと、在来線？
'expkind=1を指定しないと、普通料金だけ？
myURL = myYahoo & "/search/result?shin=1&expkind=1&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
'結果出力
Cells(nn, "D").Value = PickUpString(myContent, "片道")
Else
Cells(nn, "D").Value = "ERROR:指定なし"
End If
Next nn
Columns("A:D").AutoFit
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

回答No.1

K Kazz（@JazzCorp）

VBAの＃１は、
　　myURL = "http://transit.loco.yahoo.co.jp"
これにすると、新幹線、東京-大阪、名古屋-大阪も基本料金は正しく出るので、多分その部分だけの機能になっているのでは？
後は、回すだけ？？

お礼

わざわざご確認をいただき、ありがとうございました。

実は、マクロができる人から「機能しない」と言われて慌てて質問してしまいましたが、私が確認したところ、A1とA2へのみ表示がされるということで理解致しました。

また、この機能だと特別料金は含まれない、一番安い金額で表示されるということがわかりました。