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を改良したらできませんでしょうか?

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:
  • 終了:2014/02/19 14:21:40

ベストアンサー

id:Mook No.2

回答回数1314ベストアンサー獲得回数393

ポイント750pt

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

コメントに合わせて変更しました。

2014/02/19 00:23:27
id:sunfkin22

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

2014/02/19 14:19:04

その他の回答1件)

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

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

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

id:sunfkin22

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

2014/02/19 14:20:40
id:taknt

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

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

2014/02/19 14:29:08
id:Mook No.2

回答回数1314ベストアンサー獲得回数393ここでベストアンサー

ポイント750pt

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

コメントに合わせて変更しました。

2014/02/19 00:23:27
id:sunfkin22

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

2014/02/19 14:19:04
id:sunfkin22

Mookさん

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

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

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

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

ホテル番号

377189

313270

324255

  ・

  ・

  ・

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

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

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません