![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?5a7ff87)
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ベストアンサー
- 回答日時:
以下の方法はどうでしょうか。
ワークシートを追加して運賃検索結果を展開させます。運賃をコピー後ワークシートは削除します。運賃は出発/到着駅名の下のセル(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
- 回答日時:
こんにちは。
本格的なものはここでは出しませんが、以下を参考にしてみてください。
参照設定が何?とか、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側で自動変換してくれているのでしょうか・・・
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/03/08 09:08
- Visual Basic(VBA) Excelのマクロ ブック間である範囲をコピー Workbooks(“a.xlsx“).Sheets 3 2022/05/12 17:02
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/03/07 14:05
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/06/01 14:45
- Visual Basic(VBA) VBAコードを張り付け後のエクセルの進め方 2 2023/02/07 18:24
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2022/10/11 12:55
- Visual Basic(VBA) エクセルのマクロを使ってメールを送る方法について教えてください 2 2022/03/29 01:36
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/03/12 10:10
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/06/04 09:39
このQ&Aを見た人はこんなQ&Aも見ています
-
性格の違いは生まれた順番で決まる?長男長女・中間子・末っ子・一人っ子の性格の傾向
同じ環境で生まれ育っても、生まれ順で性格は違うものなのだろうか。家庭教育研究家の田宮由美さんに教えてもらった。
-
エクセル マクロでの株価情報収集ってできるんですか?
Excel(エクセル)
-
excle VBA とweb上の検索を利用して出発駅から到着駅まで所要時間と運賃を出したいです。
Visual Basic(VBA)
-
エクセルVBAで、Yahooの路線の片道料金を取得する
PowerPoint(パワーポイント)
-
-
4
エクセル電車賃自動計算どうやんの?
その他(開発・運用・管理)
-
5
エクセルVBA IEを操作して自動車ルート検索自動化
Excel(エクセル)
-
6
エクセルVBAでNAVITIMEを使って自動車のルート検索をして距離と高速料金を自動表示したいのです
Visual Basic(VBA)
-
7
VBAでchromeを動かしたいのですが、エラー出ます。
その他(パソコン・スマホ・電化製品)
-
8
Excelについての質問です。 2点の住所からの距離を一括で算出したいのですが データ数が5万ほどあ
Excel(エクセル)
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
バスの運賃の支払い方について...
-
【JRの回数券】使用前の変更は...
-
JR定期の払い戻しについて
-
どれくらいかかるか教えて下さい!
-
電車の運賃、途中下車は安くなる?
-
JR子供料金
-
運送会社で一番儲かる荷物は、...
-
北千住-綾瀬の料金
-
許せないレベルのデブって芸能...
-
静岡鉄道の運賃
-
株主優待券の使い方(航空券)
-
ベトナムのホーチミンから成田...
-
レベリュートンってなんですか?
-
データイムグリーン料金回数券
-
【富士急山梨バス】の運賃を教...
-
入間市駅からタクシーでアウト...
-
JRの料金と地下鉄料金の違い
-
JR四国バス-高知エクスプレス...
-
京急、東京メトロ東西線、武蔵...
-
1974年(昭和49年)10...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
タクシー代ぼったくられる事っ...
-
バスの運賃の支払い方について...
-
JRの料金は消費税込み?
-
JRの料金と地下鉄料金の違い
-
駅での見送りについてです。 A...
-
Excel VBAでインターネットを利...
-
JR子供料金
-
入間市駅からタクシーでアウト...
-
1974年(昭和49年)10...
-
高速バス(JRバスと関東鉄道...
-
佐川急便について教えてください
-
ジェットスター乗った事ないん...
-
駅間の距離を表示するサイト
-
田舎は全てにおいて、凄く不便...
-
バスの整理券って何?。
-
往復切符って
-
許せないレベルのデブって芸能...
-
安房白浜から千倉駅迄の路線バ...
-
JRに乗るには、精神の障害者手...
-
バスの乗り方を教えてください
おすすめ情報