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も見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
エクセル マクロでの株価情報収集ってできるんですか?
Excel(エクセル)
-
エクセルVBAで、Yahooの路線の片道料金を取得する
PowerPoint(パワーポイント)
-
excle VBA とweb上の検索を利用して出発駅から到着駅まで所要時間と運賃を出したいです。
Visual Basic(VBA)
-
-
4
エクセル電車賃自動計算どうやんの?
その他(開発・運用・管理)
-
5
エクセルVBAでNAVITIMEを使って自動車のルート検索をして距離と高速料金を自動表示したいのです
Visual Basic(VBA)
-
6
Excelについての質問です。 2点の住所からの距離を一括で算出したいのですが データ数が5万ほどあ
Excel(エクセル)
-
7
VBAでchromeを動かしたいのですが、エラー出ます。
その他(パソコン・スマホ・電化製品)
-
8
交通費精算表の作成(往復と記入したら金額を2倍に持っていきたい)
Access(アクセス)
-
9
エクセルVBA IEを操作して自動車ルート検索自動化
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
バスの運賃の支払い方について...
-
JRの料金は消費税込み?
-
Excel VBAでインターネットを利...
-
JRの料金と地下鉄料金の違い
-
タクシーに乗るといつも直前で...
-
駅での見送りについてです。 A...
-
往復切符って
-
高速バス(JRバスと関東鉄道...
-
駅間の距離を表示するサイト
-
JRに乗るには、精神の障害者手...
-
京急、東京メトロ東西線、武蔵...
-
佐川急便について教えてください
-
レベリュートンってなんですか?
-
北千住-綾瀬の料金
-
ジェットスター乗った事ないん...
-
夏休みに新幹線で東京⇒博多へ帰...
-
スカイマーク 障害者割引は子...
-
運賃と料金について
-
再生砕石の単価
-
1974年(昭和49年)10...
おすすめ情報