Excelで価格.comの最安値を取得、更新する方法についてです。

タブレットを購入したいのですが、どの製品もあまり性能的には変わりなく
目星をつけた複数の製品の最安値を更新ボタン１つで同時に表示して
良きタイミングで購入したいと考えています。

理想としては、
G1～G10にURLを入力し更新ボタンを押した場合(Gは例えばとして)
A1～A10に製品名称を出力、
C1～C10に最安値を出力する
といったものです。

目星をつけている製品が現在９品ありますが、
今後増える可能性があるのでその都度対応出来る様にしたいです。

また必要な情報は、製品名称と最安値のみです。
最安値は送料込みで表示したいですが、不可能な場合は送料別で問題ありません。

以上になります。よろしくお願い致します。

No.3 回答者： WindFaller 回答日時： 2015/08/07 16:27

特定の誰か宛の内容ではありませんが、#2の書き込みについて、ちょっと誤解されそうなので、補足しておきます。

「最近、こうしたマクロが、Webスクレイピングかどうかという議論で、強行な意見の持ち主もいるようですが、お互いが権利保持者ではありませんから、お互いに主張したところで無意味です。」

というのは、禁止を求めるのは、その権利を保持した人で、もし嫌うなら、Webサイトに仕掛けをするはずなのです。むろん、そのサイトの規約などに書かれていたら、仕掛けが施されていなくても、そうした行為は避けるべきだと思います。

http://www.f3.dion.ne.jp/~element/msaccess/AcTip …

>調査する
>まず対象サイトがスクレイピングを明示的に禁止していないかどうか確認する必要があります。
>スクレイピングは人間による Web サーフィンと違って、寄り道せずに必要な情報だけ持っていきます。
－中略－
>もっともスクレイピングの認知度は一般的にはまだまだ低いですから、
この頃は、まだ、それほどWebスクレイピングをする人は多くなかったのです。

http://qiita.com/nezuq/items/c5e827e1827e7cb29011
Webスクレイピングで誰も嫌な思いをしなくて済むように、……

こうしたデータの取り扱いは、慎重にしたほうが良いようです。

No.2 回答者： WindFaller 回答日時： 2015/08/07 10:59

私は、ご質問者さんのご要望には叶いませんが、#1さんが、苦心して作られたマクロをみて触発されましたので、私も同様のものを作ってみました。

また、価格COMは、かなり古くから、多くの企業では、価格COMサイトをインターネットで取得しているようです。おそらく、Webクエリをつかっているのではないかと思われます。

そのせいなのか、このサイトの規約事項を確認しましたが、Webスクレイピングは、私の見た範囲では禁止されていないようです。最近、こうしたマクロが、Webスクレイピングかどうかという議論で、強行な意見の持ち主もいるようですが、お互いが権利保持者ではありませんから、お互いに主張したところで無意味です。

また、このマクロは、現在(2015.08.07)のものであり、内容の変更があった場合は、
少なくとも
　　arbuf = Split(buf, vbCrLf)　'*
の部分で、配列の添字の調整をしなくてはなりません。1本釣りの方法もありますが、他の項目との関連性が低くなりますので、避けました。

出力先は、任意のシートです。
また、コピーした場合に、URLの部分に、別の記号などが入り込むことがありますので、実行前は、確認してくださるようにお願います。

'//
Sub InternetTestAccess()
Dim objIE As Object　 'バインディングの場合 InternetExplorer
Dim i As Long
Dim rBXn, buf, arbuf, prc
Dim ArOut As Variant
ReDim ArOut(20, 2)

Const myURL As String = "http://kakaku.com/pc/pda/ranking_0030/"
On Error GoTo ErrHandler
Set objIE = CreateObject("InternetExplorer.Application")
　'　objIE.Visible = True 'ブロックをしていると、暗黙裡に行います。
　　objIE.Navigate2 myURL
With objIE
　　Do Until Not .Busy And .ReadyState = 4: DoEvents: Loop

　Set rBXn = .Document.getElementsByClassName("rkgBox noGraph")
　If rBXn.Length > 0 Then
　 For i = 0 To rBXn.Length - 1
　　buf = rBXn(i).innerText
　　arbuf = Split(buf, vbCrLf)　'*
　　ArOut(i, 0) = Trim(arbuf(1))
　　ArOut(i, 1) = Trim(arbuf(6))
　　prc = Replace(Trim(arbuf(16)), "￥", "", , , vbTextCompare)
　　ArOut(i, 2) = prc
　 Next
　End If
　 Range("A1").Resize(1, 3).Value = Array("順位", "名称", "最安値")
　 Range("A2").Resize(20, 3).Value = ArOut
　 Columns("A:C").AutoFit
End With
ErrHandler:
objIE.Quit
　Set objIE = Nothing
End Sub
'///

No.1 回答者： RayMax 回答日時： 2015/08/06 10:52

こんにちは！

-----
目星をつけた複数の製品の最安値を更新ボタン１つで同時に表示
G1～G10にURLを入力し更新ボタンを押した場合(Gは例えばとして)
A1～A10に製品名称を出力、
C1～C10に最安値を出力する
-----
といったマクロの組み込みはわからないのですが、確認したいURL先のランキングをマクロで抽出することはできますよ！
以下参考にしていただければ幸いです。
------
・ランキング・処理というシートを作成


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("処理")

Set objIE = CreateObject("InternetExplorer.Application")

Do
lngPage = lngPage + 1

'タブレットPC(端末)・PDA 人気売れ筋ランキング
strURL = "http://kakaku.com/pc/pda/ranking_0030/"
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
.Cells.Delete
.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
For lngRow = 1 To UBound(v)
If v(lngRow, 1) Like "*位" Then
x = x + 1
vv(x, 1) = v(lngRow, 1)
vv(x, 2) = v(lngRow + 2, 1)
End If
If v(lngRow, 1) Like "最安値：*" Then
If Mid(v(lngRow, 1), 6, 1) = "―" Then
vv(x, 3) = Empty
Else
vv(x, 3) = Val(Replace(Split(Mid(v(lngRow, 1), 6), " ")(0), ",", ""))
End If
End If
Next
' WS2.Cells.Delete
WS1.Range("A2").Offset((lngPage - 1) * 20).Resize(x, 3).Value = vv

If lngPage >= 5 Then Exit Do '★上位20位まで抽出したら処理終了

Loop
Application.StatusBar = False

objIE.Quit
Set objIE = Nothing

MsgBox "取得しました"
End Sub

-----
抽出先は、URLの部分を変更していただければ変更できます！
表示する数につきましても『上位20位まで抽出したら処理終了』の部分を書き換えればできるかと！
こちらの知識不足でご希望されている通りの回答とならず申し訳ございませんが、参考にしていただけますと幸いです。