Excel VBAでインターネットを利用して運賃計算する方法

質問

Excelで交通費の精算をしているのですが、シート上に入力した出発駅名・到着駅名から、自動的に運賃が出るようにしたいと考えています。
運賃改定のことも考え、インターネット上の路線検索サイト（http:/transit.yahoo.co.jp/ 等）のデータをうまく活用したいのです。
過去の質問（ http://oshiete1.goo.ne.jp/kotaeru.php3?q=768527 )
を参考に

Sub 運賃()
On Error GoTo ERRH
syuppatu = ActiveSheet.Range("b2:b2").Value
toutyaku = ActiveSheet.Range("b3:b3").Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'---取り込み部分
Workbooks.Open Filename:= _
"http://transit.yahoo.co.jp/search?p=" & toutyaku & "&from=" & syuppatu & "&sort=0&num=0&htmb=select&kb=NON&chrg=&air=AIR&yymm=200509&dd=9&hh=16&m1=05&m2=00"
'---

ActiveSheet.Name = "new"
Sheets.Add
ActiveSheet.Name = "s" & syuppatu
Sheets("s" & syuppatu).Range("b4:b4").Value = _
Replace(Replace(Sheets("new").Range("b27:b27").Value, "運賃：片道 ", ""), "円", "")

Sheets("new").Delete
ERRH:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

というマクロを作ったのですが、別のワークブックを作成してしまう等、あまり使い勝手がよくありません。

別のワークブックを作成しないでこのような処理を行う方法はありませんでしょうか？

理想としてはユーザー定義関数のようなかたちにできればよいのですが・・・

回答No.1

ta123 · ベストアンサー

以下の方法はどうでしょうか。ワークシートを追加して運賃検索結果を展開させます。運賃をコピー後ワークシートは削除します。
運賃は出発/到着駅名の下のセル(B4)に格納するようにしました。
ユーザ関数にする方法は分かりませんでした。

Sub new運賃計算()
Dim myString As String
Dim myWS As Worksheet

Set myWS = ActiveSheet

myString = "search?p=" & myWS.Range("B2").Value & "&from=" & myWS.Range("B3").Value & "&sort=0&num=0&htmb=select&kb=NON&chrg=&air=&yymm=200509&dd=11&hh=17&m1=05&m2=00"

Application.ScreenUpdating = False
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:="URL;http://transit.yahoo.co.jp/" & myString _
, Destination:=Range("A1"))
.Name = myString
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

myWS.Range("B4").Value = Replace(Replace(ActiveSheet.Range("B25").Value, "運賃：片道 ", ""), "円", "")

Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

お礼

ありがとうございます。
希望していた処理ができました。
しかもうれしいことに元々のより処理がはやいです。
ユーザー定義関数化については別だてで改めて質問します。
助かりました。
どうもありがとうございました。

回答No.2

Wendy02

こんにちは。

本格的なものはここでは出しませんが、以下を参考にしてみてください。
参照設定が何？とか、BASP21 の使い方は、とか、起動法はどうする、というレベルでしたら、以下は使わないほうがよいかもしれません。この程度なら、私にも出来ると思う方は、こちらは無視して自分が良い思うものを出してください。なお、Yahoo のURL のオプションを分る範囲で書いておきましたので、後は、ご自身で加工してください。

なお、URL に、Unicode文字を直接当てても、正しく表示されないと思います。

kb=DEP '出発時間
kb=ARR '到着時間
kb=LST '終電
kb=NON '指定なし
chg=CHARGE '新幹線以外の有料特急を利用しない
air=AIR '空路を利用しない

Option Explicit
Private Function Unicode2EUC(name As String) As String
　 '参照設定:BASP21
　 'http://www.hi-ho.ne.jp/babaq/bsmtp.html
　 Dim bobj As Basp21 'Basp21 TypeLibrary
　 Dim buf As String
　 Dim bufarry As Variant
　 Dim s As Variant
　 Set bobj = New Basp21
　 bufarry = bobj.Kconv(name, 2)
　 For Each s In bufarry
　　　buf = buf & "%" & Hex(s)
　 Next s
　 Unicode2EUC = buf
End Function

Private Sub InternetConnect(URL As String)
'参照設定:Microsoft Internet Control
Dim objIE As InternetExplorer
Dim myContents As String
Dim myContentHTML As String
Dim ratingURL As String
Dim ret As Variant
Dim flg As Integer
Dim fst_rating　As Long, lst_rating As Long
Dim buf As String, i As Long
Set objIE = New InternetExplorer
With objIE
　 .Navigate URL
　 '.Visible =True '通常はウィンドウは出さない。
　 Do While .Busy
　　　DoEvents
　 Loop
　 Do Until .ReadyState = 4
　　　DoEvents
　　　i = i + 1
　　　If i > 3000 Then
　　　　MsgBox "アクセスできませんでした。", vbInformation: Exit Sub
　　　End If
　 Loop
　　 myContents = .Document.body.innerTEXT
　　 SplitOutLog myContents
End With

End Sub
Private Sub SplitOutLog(strLine As String)
　 Dim s As Long, i As Long, j As Long, m As Long, k As Long
　 Dim r As Long, n As Long
　 Dim buf As String, tmp As String
　 '切り出し
　 s = 1
　 r = 1
　 Do
　　　i = InStr(s, strLine, "運賃：片道 ")
　　　If i = 0 Then Exit Do
　　　buf = Mid$(strLine, i + 6)
　　　j = InStr(buf, "円")
　　　Cells(r, 1).Value = Mid$(buf, 1, j - 1)
　　　m = InStr(buf, "駅")
　　　k = InStr(m - 10, buf, vbCrLf)
　　　n = InStr(m, buf, "円")
　　　tmp = VBA.Trim(Mid$(buf, k + 2, n - k - 1))
　　　Cells(r, 2).Value = Replace(tmp, vbCrLf, "")
　　　strLine = Mid$(buf, n)
　　　r = r + 1
　 Loop
End Sub
Sub Main()
　 Dim Start As String, Destine As String
　 Dim myTime As Date, yy As String, dd As String, mon As String
　 Dim hh As String, m1 As String, m2 As String
　 Dim StartEUC As String, DestineEUC As String
　 Dim URL As String
　 '出発地と目的地
　 Start = Application.InputBox("出発点を入れてください", Type:=2)
　 If Start = "" Then Exit Sub
　 Destine = Application.InputBox("目的地を入れてください", Type:=2)
　 If Destine = "" Then Exit Sub
　 '時間
　 myTime = Now + TimeValue("00:00:30")
　 yy = Year(myTime): mon = Month(myTime)
　 dd = Day(myTime)
　 hh = Hour(myTime)
　 m1 = "0" & Left$(Format(Minute(myTime), "00"), 1)
　 m2 = "0" & Right$(Format(Minute(myTime), "00"), 1)
　 '確認
　 MsgBox "出発点 :" & Start & vbCrLf & "目的地 :" & Destine & vbCrLf & _
　 "時刻 :" & Format$(myTime, "yyyy年m月d日 hh時mm分") & " 以降"
　 'EUCに変換
　 StartEUC = Unicode2EUC(Start)
　 DestineEUC = Unicode2EUC(Destine)
　 URL = "http://transit.yahoo.co.jp/search?p=" _
　 & DestineEUC & "&from=" & StartEUC _
　 & "&sort=0&num=0&htmb=result&kb=NON&chrg=&air=&yymm=" _
　 & yy & mon & "&dd=" & dd & "&hh=" & hh & "&m1=" & m1 & "&m2=" & m2
　 InternetConnect URL
　 'フォーマットを整える
　 Cells(1, 1).CurrentRegion.MergeCells = False
　 Cells(1, 1).Select
End Sub

お礼

ありがとうございます。
わざわざ長いコードまで作っていただき非常に恐縮です。

＞参照設定が何？とか、BASP21 の使い方は、とか、
＞起動法はどうする、というレベルでしたら、以
＞下は使わないほうがよいかもしれません。

それ以下のレベルです(^^ゞ
試行錯誤して、参照設定等を行って、なんとか動かすことができました。
おかげさまで希望していた処理ができました。
ありがとうございます。

でも、何の処理をしているのか私ごときではほとんどわかりません・・・
カスタマイズするため、気合を入れて勉強・解読したいと思います。

YahooのURLオプション、日時の設定方法等もとても参考になります。

本当にありがとうございました。

p.s. URLにUnicode文字（＝漢字など？）を直接当ててもなぜか正しく表示されました。yahoo側で自動変換してくれているのでしょうか・・・