EXCEL kakaku.com 最安価格の更新 可能でしょうか

質問

ノートPC数台導入につき、
現在、Kakaku.comにて候補を挙げ、
Excel2003にて比較表を作成しているのですが、

ファイルを開いた時点で価格情報を現時点での最安価格に更新
する方法はないでしょうか。

現在は、都度、サイトにアクセスし、
機種ごとに価格をコピー&ペーストして更新していますが、
10機種ほどピックアップしているため手間がかかること、
今後もこのような対応が定期的に必要となるため、

なるべく自動更新に近い方法があればご教示よろしくお願い致します。

比較表はスクリーンショット添付しましたので、ご参照いただければと思います。
また比較表はkakaku.comの製品詳細比較機能で作成できるテーブルを
編集して作成しています。

更新したい情報は赤枠で囲んだ各モデルの最安価格となります。
ショップ名等の情報は不要です。

以上，よろしくお願い致します。

回答No.3

Wendy02 · ベストアンサー

こんばんは。

標準モジュールに貼りつけます。

以下のユーザー設定の部分を書き換えてください。
フォームのコマンドボタンなので、このマクロを登録してくれれば、それをクリックするだけで価格を取得できます。こちらでは、成功しています。

設定の仕方：
ここに、該当する個々の機種のURLをセルに書き込み、P列なら、P列に書き込みます。縦でも横でもよいです。
Set rngData = .Range("P1:P10")　

出力する場所で、画像をみると、以下のように見えました。
Set outData = .Range("B26:K26")

URLの数と、書き込むセルの数さえ合わせていただければ良いです。

''標準モジュール
'-------------------------------------------
Sub Main()
　　Dim sPrice As String
　　Dim i As Long
　　Dim rngData As Range
　　Dim outData As Range
　　'出力が遅いと感じたら、以下を外します。
　　'Application.ScreenUpdating = False
　　With ActiveSheet
　　'-------------------------------------------
　　''ユーザー設定
　　 '必要なURLをP1～P10 に書き込む
　　Set rngData = .Range("P1:P10")
　　'書き出す場所
　　Set outData = .Range("B26:K26")
　　'-------------------------------------------
　　For i = 1 To rngData.Cells.Count
　　　　If rngData.Cells(i).Value <> "" Then
　　　　　　sPrice = GetPrices(rngData.Cells(i).Value)
　　　　　　If sPrice <> "" Then
　　　　　　　　outData.Cells(i).Value = sPrice
　　　　　　End If
　　　　End If
　　Next i
　　End With
　　'Application.ScreenUpdating = True
End Sub
Function GetPrices(ByVal strURL As String)
'価格.COMから、最安値を取得する関数
Dim objHTTP As Object
Dim httpLog As String
Dim i As Long
Dim buf As String
Dim Matches As Object
'10/02/08 現在の価格.COMのHTMLコード
'サイトの内容が変わって取れなくなったら、sKEYの部分を書き換えてください。
Const sKEY As String = "lid=shop_itemview_"
　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　On Error Resume Next
　　objHTTP.Open "GET", strURL, False
　　objHTTP.Send
　　On Error GoTo 0
　　On Error GoTo ErrHandler
　　If objHTTP.Status = 200 Then
　　　　 httpLog = objHTTP.ResponseText
　　End If
　　i = InStr(1, httpLog, sKEY, 1)
　　If i > 0 Then
　　buf = Mid$(httpLog, i + Len(sKEY), 30)
　　With CreateObject("VBScript.RegExp")
　　　.Pattern = "yen;([\d,]+)"
　　　.Global = False
　　　 Set Matches = .Execute(buf)
　　　 buf = Matches(0).SubMatches(0)
　　　 GetPrices = buf
　　End With
　　End If
ErrHandler:
If Err.Number > 0 Then
　 GetPrices = ""
End If
Set objHTTP = Nothing
End Function

お礼

大変連絡が遅くなり申し訳ありません。
本日、早速試してみました。

見事です!感動しました!

これで手間が大幅に軽減されます。
本当にありがとうございました。

回答No.2

Wendy02

こんにちは。

私なら、マクロがよいのではないかと思いますが、そういう方向でよろしいのでしょうか？
シートにURLを書いてもらって、それを順に呼び出すスタイルにします。

しかし、ご質問者さんの過去の質問の対応を見ていると、何のコメントも付けずに締めてしまったりしていますので、一応、コードを掲載したりするのは、きちんとした確認をしてからにさせていただきます。マクロのコードが不要でしたら、無視しても構いません。#1様の方法でも、Webサイトから一括してして取れれば問題はないと思います。そうでない場合は、その数だけWebクリエを作らなくてはならないかもしれません。私は専門家ではありませんので、間違いかもしれませんが。

お礼

Wendy02さん

回答ありがとうございます。
よろしければ、マクロいただけないでしょうか。

作成していただくにあたって、さらになにか情報が必要であれば
お知らせください。

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

回答No.1

MackyNo1

「データ」「外部データの取り込み」で「新しいWebクエリ」で該当するWebページの表を取り込めば、いつでも最新のデータを参照することができます。