人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

VBA:webサイトからデータ抽出

http://www.jalan.net/us/usp3000/usw3001.do?screenId=USW3001&Count=10&stayDay=01&nextPageCount=10&stayCount=1&yadNo=377189&maxPrice=999999&rootCd=7705&stayMonth=03&dispCount=10&srcScreenId=USW3001&roomCount=1&stayYear=2014&adultNum=2&pageLimit=10&minPrice=0&reShFlg=1&pagingFlg=0&idx=0&activeSort=1&tabFlg=1

こちらのサイトから、土日、祝日3ヶ月分の最安値(一番上のプランと金額)をExcelに
抽出できませんでしょうか?

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1461447184
このVBAを改良したらできませんでしょうか?

よろしくお願い致します。


●質問者: にゃんころね
●カテゴリ:ビジネス・経営 コンピュータ
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● きゃづみぃ
●100ポイント
Sub Sample1()
 Dim objIE As Object
 Dim strURL As String
 Dim WS1 As Worksheet
 Dim WS2 As Worksheet
 Dim v As Variant
 Dim lngRow As Long, lngPage As Long
 Dim vv(1 To 20, 1 To 3) As Variant
 Dim x As Long
 
 Set WS1 = Worksheets("結果")
 Set WS2 = Worksheets("作業")
 
 
 WS1.Cells.Delete
 WS2.Cells.Delete
 
 Set objIE = CreateObject("InternetExplorer.Application")
 
' Do
 lngPage = lngPage + 1
 
 strURL = "http://www.jalan.net/us/usp3000/usw3001.do?screenId=USW3001&Count=10&stayDay=01&nextPageCount=10&stayCount=1&yadNo=377189&maxPrice=999999&rootCd=7705&stayMonth=03&dispCount=10&srcScreenId=USW3001&roomCount=1&stayYear=2014&adultNum=2&pageLimit=10&minPrice=0&reShFlg=1&pagingFlg=0&idx=0&activeSort=1&tabFlg=1"
 If lngPage > 1 Then
 strURL = strURL & "page=" & lngPage
 End If
 Application.StatusBar = lngPage & " ページを取得中"
 
 With objIE
 .Navigate strURL
 Do While .Busy
 DoEvents
 Loop
 Do While .ReadyState <> 4
 DoEvents
 Loop
 .ExecWB 17, 2, 0, 0
 .ExecWB 12, 2, 0, 0
 End With
 
 With WS2
 .Paste .Range("A1")
 .Hyperlinks.Delete
 .DrawingObjects.Delete
 .UsedRange.EntireColumn.AutoFit
 With Application
 .CutCopyMode = False
 .ScreenUpdating = True
 End With
 With .Cells
 .WrapText = False
 .Orientation = 0 'セル結合解除
 .AddIndent = False
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 .MergeCells = False
 End With
 End With
 v = WS2.UsedRange.Value
 x = 0
 
 WS1.Cells(1, 1) = "プラン名"
 WS1.Cells(1, 2) = "金額"
 
 For lngRow = 1 To UBound(v)
 If v(lngRow, 1) = "安い順" Then
 WS1.Cells(2, 1) = v(lngRow + 2, 1)
 WS1.Cells(2, 2) = v(lngRow + 4, 1)

 Exit For
 End If

 Next
 
' Loop
 Application.StatusBar = False
 
 objIE.Quit
 Set objIE = Nothing
 
 MsgBox "取得しました"
End Sub

参考先のVBAを 変更してみました。

土日、祝日3ヶ月分の最安値というのは わかりませんが
一番上のプランと金額とあるので 一番上のものを もってくるようにしてみました。


にゃんころねさんのコメント
3ヶ月分の部分が伝わらなかったようですが、回答頂いたのでわずかばかりですがポイントを進呈させて頂きます。

きゃづみぃさんのコメント
提示されたURLを開いた状態で どのように3か月とするのかを 詳しく書いてもらえれば 期待にそえるものができたと思いますよ。 足りなければ 補足してもらえればいいだけですが、その補足もありませんでしたね。

2 ● Mook
●750ポイント ベストアンサー

シートのA列に施設、1行目に集したい日付を列挙して収集する例です。

こちらはおまけ。
最初に Set3MonthHolidays 実行してください。

上に続けて GetTopPlan を実行してください。

Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub GetTopPlan()
 Dim objIE As Object
 Set objIE = CreateObject("InternetExplorer.Application")
 
 Dim strURL As String
 Dim r, c
 For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
 For c = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
 strURL = "http://www.jalan.net/us/usp3000/usw3001.do?screenId=USW3001&Count=10" _
 & "&stayDay=" & Format(Cells(1, c).Value, "DD") _
 & "&nextPageCount=10&stayCount=1&yadNo=" & Cells(r, "A").Value _
 & "&maxPrice=999999&rootCd=7705" _
 & "&stayMonth=" & Format(Cells(1, c).Value, "MM") _
 & "&dispCount=10&srcScreenId=USW3001&roomCount=1&stayYear=2014&adultNum=2&pageLimit=10&minPrice=0&reShFlg=1&pagingFlg=0&idx=0&activeSort=1&tabFlg=1"
 
 With objIE
 .Navigate strURL
' .Visible = True
 Do While .Busy Or .ReadyState <> 4
 DoEvents
 Loop
 End With
 
 Dim plan, txt
 Set plan = objIE.document.getElementByID("planListElem").GetElementsByTagName("li")
 If plan.Length > 0 Then
 For Each txt In Split(plan(0).innerText, vbNewLine)
 If InStr(txt, "合計") > 0 Then
 Cells(r, c).Value = Trim(Replace(Split(txt, "円")(0), "合計", ""))
 Exit For
 End If
 Next
 Else
 Cells(r, c).Value = ""
 End If
 Sleep (300)
 Next
 Next
 objIE.Quit
End Sub

Sub Set3MonthHolidays()
 Dim dt
 dt = Array("2/22", "2/23", "3/1", "3/2", "3/8", "3/9", "3/15", "3/16", "3/21", "3/22", "3/23", "3/29", "3/30", "4/5", "4/6", "4/12", "4/13", "4/19", "4/20", "4/26", "4/27", "4/29", "5/2", "5/3", "5/4", "5/5", "5/6", "5/10", "5/11", "5/17", "5/18")
 Range("B1").Resize(1, UBound(dt) + 1) = dt
 dt = Array("377189", "313270", "324255")
 Range("A2").Resize(UBound(dt) + 1, 1) = Application.Transpose(dt)
End Sub

Mookさんのコメント
コメントに合わせて変更しました。

にゃんころねさんのコメント
私の未熟なVBA知識からすると、いつもMookさんに回答頂いているコードは大変助かっています。 またポイント加算させて頂きたいと思います。 ありがとうございました!

質問者から

Mookさん
上記のコードを次のように修正は可能でしょうか?

・日付、取り込んだデータは横に集計。
・取り込みたいデータは合計の金額だけを取り込みたい。 61,000というように。
・ホテル番号をsheet2に記入しておいて複数のホテルの最安値を取り込みたい。
ホテル番号
377189
313270
324255




お手数をお掛けしますが、よろしくお願い致します。


関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ