![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
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も見ています
-
性格の違いは生まれた順番で決まる?長男長女・中間子・末っ子・一人っ子の性格の傾向
同じ環境で生まれ育っても、生まれ順で性格は違うものなのだろうか。家庭教育研究家の田宮由美さんに教えてもらった。
-
excle VBA とweb上の検索を利用して出発駅から到着駅まで所要時間と運賃を出したいです。
Visual Basic(VBA)
-
エクセル電車賃自動計算どうやんの?
その他(開発・運用・管理)
-
エクセルVBAで、Yahooの路線の片道料金を取得する
PowerPoint(パワーポイント)
-
-
4
エクセル マクロでの株価情報収集ってできるんですか?
Excel(エクセル)
-
5
エクセルVBA IEを操作して自動車ルート検索自動化
Excel(エクセル)
-
6
VBAでchromeを動かしたいのですが、エラー出ます。
その他(パソコン・スマホ・電化製品)
-
7
Excelについての質問です。 2点の住所からの距離を一括で算出したいのですが データ数が5万ほどあ
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
バスの運賃の支払い方について...
-
学割と往復割引の併用
-
JRの料金は消費税込み?
-
みどりの窓口
-
JRの切符で料金が不足した切符...
-
常磐線特急ひたち 幼児料金につ...
-
新幹線の乗車券で旅行会社にチ...
-
私の大学は学割証発行機で学割...
-
新幹線の乗車券を購入後、途中...
-
駅の切符は出発駅買ったあと、...
-
急いでます!!!特急あずさの...
-
切符乗り換え方法 切符での乗り...
-
松本から新宿まで特急を使い、...
-
自転車に乗るって言葉を熟語に...
-
往復の学割証で、片道切符だけ...
-
いわゆる「大回り乗車」が目の...
-
この乗り換え不要っていうのは...
-
みどりの窓口に朝行列ができて...
-
新幹線で自由席の券買ったんで...
-
JR乗車券のみを前もって購入す...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
バスの運賃の支払い方について...
-
JRの料金は消費税込み?
-
Excel VBAでインターネットを利...
-
タクシー代ぼったくられる事っ...
-
駅での見送りについてです。 A...
-
JRの料金と地下鉄料金の違い
-
佐川急便について教えてください
-
往復切符って
-
スカイマーク 障害者割引は子...
-
どれくらいかかるか教えて下さい!
-
駅間の距離を表示するサイト
-
新神戸港から大分港までのフェ...
-
阪急電鉄と地下鉄の運賃と所要時間
-
高速バス(JRバスと関東鉄道...
-
ベトナムのホーチミンから成田...
-
田舎は全てにおいて、凄く不便...
-
定期券の期間変更について
-
静岡鉄道の運賃
-
枚方市駅~高槻市駅のバス
-
CIF条件での貨物保険の保険期間...
おすすめ情報