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

Question

にゃんころね

20

19もっと見る

850pt

ビジネス・経営コンピュータ

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

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

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

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

回答の条件

1人5回まで

登録：2014/02/16 19:10:51
終了：2014/02/19 14:21:40

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.1

きゃづみぃ1353911982014/02/16 22:31:28

100pt

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を変更してみました。

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

３ヶ月分の部分が伝わらなかったようですが、回答頂いたのでわずかばかりですがポイントを進呈させて頂きます。

2014/02/19 14:20:40

提示されたURLを開いた状態でどのように3か月とするのかを詳しく書いてもらえれば期待にそえるものができたと思いますよ。

足りなければ補足してもらえればいいだけですが、その補足もありませんでしたね。

2014/02/19 14:29:08

質問者から

にゃんころね2014/02/17 11:15:59

Mookさん

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

・日付、取り込んだデータは横に集計。

・取り込みたいデータは合計の金額だけを取り込みたい。　61,000というように。

・ホテル番号をsheet2に記入しておいて複数のホテルの最安値を取り込みたい。

ホテル番号

377189

313270

324255

　・

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

規約違反として通知

Mook 2014/02/19 20:26:01

上記の変更で参考になったようであれば、何よりです。
日付やホテルのコードはシートに直接入力でもかまいません。

追加ポイントもありがとうございました。

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

Mook · Accepted Answer · 2014-02-17T00:42:21+09:00

シートの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 · Accepted Answer · 2014-02-17T00:42:21+09:00

シートの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

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

ベストアンサー

Mook13143932014/02/17 00:42:21

その他の回答（1件）

きゃづみぃ1353911982014/02/16 22:31:28

Mook13143932014/02/17 00:42:21ここでベストアンサー

質問者から

コメント（1件)

この質問への反応（ブックマークコメント）