エクセルVBAとWEBクエリに関する質問です。


エクセルVBAとWEBクエリを駆使し

WEBページからデータを次々とエクセルへ入力するプログラムを作成したいと考えています。

データを抜き取ってくるページはヤフーオークションです。

抜き取りたいデータは以下の写真1~12にあるデータになります。

抜き取りたいデータ(写真1):http://oskuni7.sakura.ne.jp/hatena/question7/pic1.jpg

抜き取りたいデータ(写真2):http://oskuni7.sakura.ne.jp/hatena/question7/pic2.jpg

データを読み込むエクセルは以下のようになります。

http://oskuni7.sakura.ne.jp/hatena/question7/query.htm

プログラムを実行すると、商品URLのURLへ飛び、その後写真番号1番のデータから順番に次々とエクセルへデータを書き込んでいくというプログラムになります。。

WEBクエリとVBAを駆使して以上のようなことをすることは可能でしょうか?

もし可能でしたらどのようにすれば可能になるか教えていただけないでしょうか?

もし不可能でしたらどのような工程を経たら可能になるでしょうか?

お手数をおかけしますがご回答をよろしくお願いいたします。

回答の条件
  • 1人50回まで
  • 登録:2009/01/09 21:07:34
  • 終了:2009/01/16 21:10:02

ベストアンサー

id:Mook No.6

Mook回答回数1312ベストアンサー獲得回数3912009/01/11 21:21:03

ポイント17pt

EXCEL の VBA を使用した例です。

ただ、この方法はサイトの形式が変わるとデータが取れなくなる欠点がありますし、

ページによって書式が違う場合もデータがとれません。


Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub getAuctionInfo()
    Dim objIE As Object
    Const startRow = 3
    Set objIE = CreateObject("InternetExplorer.application")
    objIE.Visible = True

    Dim lastRow As Long
    lastRow = Range("A" & startRow).End(xlDown).Row
    
    Dim i As Long
    For i = startRow To lastRow
        browsAndGetInfo objIE, Cells(i, "A").Value, i
    Next
    objIE.Quit
End Sub

Sub browsAndGetInfo(objIE, url As String, num As Long)
    objIE.Navigate url

    While objIE.ReadyState <> 4
        While objIE.Busy = True
            DoEvents
            Sleep 300
        Wend
    Wend

    Cells(num, "B").Value = objIE.Document.getElementsByTagName("H1").Item(0).innertext
    Cells(num, "C").Value = objIE.Document.getElementById("modCtgPath").innertext
    
    Dim es As Object
    Dim ls As Variant
    Dim ll As Variant
    Dim ws As Variant
    Dim i As Long
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("h3")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "出品者の情報" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "出品者"
                        Cells(num, "C").Value = Replace(ws(1), "(自己紹介)", "")
                    End Select
                End If
            Next
        End If
    Next

'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("th")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "現在の価格" Then
            ls = Split(es.Item(i).ParentNode().ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "現在の価格"
                        Cells(num, "E").Value = Replace(ws(1), "(自己紹介)", "")
                    Case "即決価格"
                        Cells(num, "F").Value = ws(1)
                    Case "残り時間"
                        Cells(num, "G").Value = Replace(ws(1), "(詳細な残り時間)", "")
                    Case "入札件数"
                        Cells(num, "H").Value = Replace(ws(1), "(入札履歴)", "")
                    End Select
                End If
            Next
        End If
    Next
    
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("p")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "詳細情報" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "開始時の価格"
                        Cells(num, "I").Value = ws(1)
                    Case "落札者"
                        Cells(num, "J").Value = ws(1)
                    Case "開始日時"
                        Cells(num, "K").Value = ws(1)
                    Case "終了日時"
                        Cells(num, "L").Value = ws(1)
                    Case "オークションID"
                        Cells(num, "M").Value = ws(1)
                    End Select
                End If
            Next
        End If
    Next
End Sub
id:aiomock

ご回答ありがとうございます。

試してみたいと思います。

2009/01/12 14:43:56

その他の回答(6件)

id:niwa-mikiho No.1

niwa-mikiho回答回数508ベストアンサー獲得回数382009/01/09 23:59:28

ポイント18pt

出来るとは思いますが、WEB に特化されたスクリプトである PHP や Perl を使った方がいいと思います。

データの格納には MySQL や SQLite を使えばいいかと思います。

スクリプトで html を取得

正規表現で抜き出す

それらデータをデータベースにプッシュ

あとは定期的にバックアップでもとればよいかと。

こうすることで、よほど変な風に組まなければ Linux でも Windows でも同じスクリプトが動作します。

id:aiomock

ご回答ありがとうございます。

2009/01/10 03:36:16
id:fester No.2

fester回答回数124ベストアンサー獲得回数202009/01/10 00:40:24

id:aiomock

ご回答ありがとうございます。

2009/01/10 03:36:19
id:ardarim No.3

ardarim回答回数892ベストアンサー獲得回数1422009/01/10 19:26:45

ポイント17pt

WinHTTPやXMLHTTPでも試したことがありますが、ヤフオクのデータを取得する場合に限っていえば、ログインをどうやるかが問題です。

WinHTTPやXMLHTTPだとIEのcookieを流用できないのでVBAから手動でログイン操作とcookie管理を行わねばならず、(できなくはないですが)相当難しいと思います。

また、取れるのは生HTML(ヤフオクの場合EUC)なので、Excelで扱うには文字コード変換が必要です。(VBAにはEUCの変換機能はないので自力で作らねばならない。作ったことがあるので作れないわけではないですが)


こちらでちょろっとやり方を書いてますので参考になれば。

http://d.hatena.ne.jp/ardarim/20070110/1168449396

このやり方で条件に挙げるようなすべてのデータを取得してExcelで管理するVBAが作れます(実際に使ってます)

id:aiomock

ご回答ありがとうございます。

ブログのほう拝見させていただきました。

今回はログイン機能は今のところ使用せず、ヤフオクの場合はゲストの状態で情報を取得するので

WinHTTPもしくはXMLHTTPを使ってみようかと思いました。

その際、ポイントとなってくるのはEUCの変換となりそうなのですが、やはり変換は難しいでしょうか?

また今回はデータを抽出するケースですが、逆にフォームの中にデータをどんどん入力していくケース、自動出品ソフトやメールフォーム一括入力などもこれと同じ様にWinHTTP等を使用すればできるのでしょうか?

その場合はログイン機能を使いたいと考えているのですが、、、。

よくわからず仕舞いですが、もし知っておりましたらご回答をよろしくお願いいたします。

2009/01/11 03:06:01
id:blue0rice0star No.4

blue0rice0star回答回数12ベストアンサー獲得回数02009/01/11 09:52:26

ポイント17pt

ExcelVBAなら問題なくできます 

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1220007...

こちらが参考になると思います XP IE6 Excel2000 での確認です

サンプルが必要なら用意します

http://www.formzu.net/fgen.ex?ID=P33169656

id:aiomock

ご回答ありがとうございます。

2009/01/12 14:38:53
id:ardarim No.5

ardarim回答回数892ベストアンサー獲得回数1422009/01/11 12:56:18

ポイント17pt

ヤフオクで使う前提であれば、XMLHTTPよりWinHTTPを使うことをお勧めします。XMLHTTPではうまく動かない場合がありました。ランダムなのか条件は分かりませんが、特定アイテムの詳細ページをロードした場合にヤフオクがログインページにリダイレクトするレスポンスを返すことがあり、XMLHTTPはリダイレクトをうまく扱えないためです。


VBAでのEUC変換については外部DLLを呼び出すか、IEのコンポーネントを利用するか、自力で関数を書くか、などの方法があり「vba euc」で検索すれば色々見つかります。


データの取出しとは逆にフォームに値を埋めていく場合は、WinHTTPでも可能だと思いますが、前回答で書いたとおりログイン状態を維持するのが難しい(というかできるかどうか不明)と思います。

cookie管理を別にして考えれば、フォームデータをVBAで作ってWinHTTPでPOSTするだけですのでそんなに難しいことではありません。


簡単なのは、IEをCOM経由で起動して操作することです(前回書いた方法です)。この場合はIEがcookieの管理をやってくれますので、表示されるIEのログイン画面でログインする(またはVBAからパスワードなどを流し込んで自動ログインする)ことで後はすべてIEに任せられます。

この場合はフォームデータはIE上のそれぞれの入力欄に対して、VBAから流し込む(document.getElementById('xxxx').value = 'yyyy'など)必要があります。


ただし、最近のヤフオクのシステム変更で操作にFlashやJavaScriptが多用されるようになったのでいずれにせようまく動かすために解析するのは難しいかもしれません。

id:aiomock

ご回答ありがとうございます。

データの埋め込みはWinHTTPがいいということですね^^。

参考にさせていただきます。

2009/01/13 12:19:06
id:Mook No.6

Mook回答回数1312ベストアンサー獲得回数3912009/01/11 21:21:03ここでベストアンサー

ポイント17pt

EXCEL の VBA を使用した例です。

ただ、この方法はサイトの形式が変わるとデータが取れなくなる欠点がありますし、

ページによって書式が違う場合もデータがとれません。


Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub getAuctionInfo()
    Dim objIE As Object
    Const startRow = 3
    Set objIE = CreateObject("InternetExplorer.application")
    objIE.Visible = True

    Dim lastRow As Long
    lastRow = Range("A" & startRow).End(xlDown).Row
    
    Dim i As Long
    For i = startRow To lastRow
        browsAndGetInfo objIE, Cells(i, "A").Value, i
    Next
    objIE.Quit
End Sub

Sub browsAndGetInfo(objIE, url As String, num As Long)
    objIE.Navigate url

    While objIE.ReadyState <> 4
        While objIE.Busy = True
            DoEvents
            Sleep 300
        Wend
    Wend

    Cells(num, "B").Value = objIE.Document.getElementsByTagName("H1").Item(0).innertext
    Cells(num, "C").Value = objIE.Document.getElementById("modCtgPath").innertext
    
    Dim es As Object
    Dim ls As Variant
    Dim ll As Variant
    Dim ws As Variant
    Dim i As Long
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("h3")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "出品者の情報" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "出品者"
                        Cells(num, "C").Value = Replace(ws(1), "(自己紹介)", "")
                    End Select
                End If
            Next
        End If
    Next

'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("th")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "現在の価格" Then
            ls = Split(es.Item(i).ParentNode().ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "現在の価格"
                        Cells(num, "E").Value = Replace(ws(1), "(自己紹介)", "")
                    Case "即決価格"
                        Cells(num, "F").Value = ws(1)
                    Case "残り時間"
                        Cells(num, "G").Value = Replace(ws(1), "(詳細な残り時間)", "")
                    Case "入札件数"
                        Cells(num, "H").Value = Replace(ws(1), "(入札履歴)", "")
                    End Select
                End If
            Next
        End If
    Next
    
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("p")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "詳細情報" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "開始時の価格"
                        Cells(num, "I").Value = ws(1)
                    Case "落札者"
                        Cells(num, "J").Value = ws(1)
                    Case "開始日時"
                        Cells(num, "K").Value = ws(1)
                    Case "終了日時"
                        Cells(num, "L").Value = ws(1)
                    Case "オークションID"
                        Cells(num, "M").Value = ws(1)
                    End Select
                End If
            Next
        End If
    Next
End Sub
id:aiomock

ご回答ありがとうございます。

試してみたいと思います。

2009/01/12 14:43:56
id:Mook No.7

Mook回答回数1312ベストアンサー獲得回数3912009/01/14 00:38:34

ポイント17pt

ほとんど先の回答と同じコードですが、出品者の情報をとれるように改良しました。

(若干の処理の改良もしています。)


こちらでは落札者は出ていますが、出ていませんか?

出ていないのは、即決価格ですが、これは元のページに情報がないためです。


表示されているのに情報が取れない場合は、対象とした URL を提示ください。

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub getAuctionInfo()
    Dim objIE As Object
    Const startRow = 3
    Set objIE = CreateObject("InternetExplorer.application")
    objIE.Visible = True

    Dim lastRow As Long
    lastRow = Range("A" & startRow).End(xlDown).Row
    
    Dim i As Long
    For i = startRow To lastRow
        browsAndGetInfo objIE, Cells(i, "A").Value, i
    Next
    objIE.Quit
End Sub

Sub browsAndGetInfo(objIE, url As String, num As Long)
    objIE.Navigate url

    While objIE.ReadyState <> 4
        While objIE.Busy = True
            DoEvents
            Sleep 300
        Wend
    Wend

    Cells(num, "B").Value = objIE.Document.getElementsByTagName("H1").Item(0).innertext
    Cells(num, "C").Value = objIE.Document.getElementById("modCtgPath").innertext
    
    Dim es As Object
    Dim ls As Variant
    Dim ll As Variant
    Dim ws As Variant
    Dim i As Long
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("th")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "出品者" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "出品者"
                        Cells(num, "D").Value = Replace(ws(1), "(自己紹介)", "")
                    End Select
                End If
            Next
            Exit For
        End If
    Next

'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("th")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "現在の価格" Then
            ls = Split(es.Item(i).ParentNode().ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "現在の価格"
                        Cells(num, "E").Value = Replace(ws(1), "(自己紹介)", "")
                    Case "即決価格"
                        Cells(num, "F").Value = ws(1)
                    Case "残り時間"
                        Cells(num, "G").Value = Replace(ws(1), "(詳細な残り時間)", "")
                    Case "入札件数"
                        Cells(num, "H").Value = Replace(ws(1), "(入札履歴)", "")
                    End Select
                End If
            Next
            Exit For
        End If
    Next
    
'-----------------------------------
    Set es = objIE.Document.getElementsByTagName("p")
    For i = 0 To es.Length - 1
        If es.Item(i).innertext = "詳細情報" Then
            ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
            For Each ll In ls
                If InStr(ll, ":") > 0 Then
                    ws = Split(ll, ":")
                    Select Case Trim(ws(0))
                    Case "開始時の価格"
                        Cells(num, "I").Value = ws(1)
                    Case "落札者"
                        Cells(num, "J").Value = ws(1)
                    Case "開始日時"
                        Cells(num, "K").Value = ws(1)
                    Case "終了日時"
                        Cells(num, "L").Value = ws(1)
                    Case "オークションID"
                        Cells(num, "M").Value = ws(1)
                    End Select
                End If
            Next
            Exit For
        End If
    Next
End Sub
id:aiomock

ご回答ありがとうございます。

実行してみたのですが出品者のところだけ取得できない状況です。

落札者のところは情報が取得できました。

エクセルに問題があるかもしれないので、私のエクセルをアップさせていただきました。

http://oskuni7.sakura.ne.jp/hatena/question8/excel.xls

お時間があるときでよろしいですので確認できましたらよろしくお願いいたします。

2009/01/14 01:05:02
  • id:Mook
    あらら、コードにバグが・・・。現在の価格の
    Cells(num, "E").Value = Replace(ws(1), "(自己紹介)", "")

    Cells(num, "E").Value = Replace(ws(1), "(入札はこちら)", "")
    に変更ください。
  • id:aiomock
    Mook さん

    プログラム実行しました。

    実行したところ以下のエラーメッセージが出ます。

    コンパイル エラー

    定数、固定長文字列、配列、ユーザー定義型および Declare ステートメントは、
    オブジェクト モジュールのパブリック メンバとしては使用できません。

    問題とされているコードは始めの

    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

    のところです。

    お手数をおかけしますがよろしくお願いいたします。
  • id:Mook
    Sleep の宣言は標準モジュールに書く必要があります。

    全体のコードをシートモジュールではなく標準モジュールに置き、実行してください。
  • id:aiomock
    Mook さん 

    ご回答ありがとうございます。

    プログラム実行できました。

    実行できましたが出品者 と 7、落札者 のデータが抽出されない状況です。

    こちらはどのようにすれば抽出できるようになりますでしょうか?

    お手数をおかけしますがよろしくお願いいたします。
  • id:Mook
    失礼しました。
    出品者は
    Case "出品者"
    Cells(num, "C").Value = Replace(ws(1), "(自己紹介)", "")
    ではなく
    Case "出品者"
    Cells(num, "D").Value = Replace(ws(1), "(自己紹介)", "")
    ですね。
    落札者のデータは入ってますか?

    夜にでも、コメントで対応します。
  • id:aiomock
    Mook さん

    ご回答ありがとうございます。

    CをDに変えて実行してみました。

    変更し実行してみましたが未だデータが抽出されない状況です。

    落札者データも抽出できません。

    お手数をおかけしますがよろしくお願いいたします。

  • id:Mook
    先のコメントは、「表示しているWeb に落札者が入っていますか?」
    という意味でお聞きしました。

    アップいただいたEXCEL に標準モジュールを挿入、2回目の回答をそのままコピー、
    実行で、すべての項目が取得できました。

    こちらの環境は IE6+Office2007 ですが、何をお使いでしょうか。

    でも、ほかの項目が表示できているのであれば、とれるはずなのですが・・・。


    If es.Item(i).innertext = "現在の価格" Then
      ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
      For Each ll In ls
    の部分に
    If es.Item(i).innertext = "現在の価格" Then
      Debug.Print es.Item(i).ParentNode().innertext
      ls = Split(es.Item(i).ParentNode().innertext, vbNewLine)
      For Each ll In ls
    のようにして、VBEのイミディエイトウィンドウに表示された中に、該当の文字列はあるか
    確認いただけますか。
  • id:aiomock
    Mook さん

    ご回答ありがとうございます。

    こちらOffice2003、IE7.0になります。

    先ほど実行したところ、プログラムが実行できなくなりました。

    エラーメッセージですが

    実行時エラー 429

    ActiveX コンポーネントはオブジェクトを生成できません。

    というエラーメッセージです。

    Mookさんに回答を頂き、動くかと思った矢先の出来事でした。

    いろいろお手数をおかけし本当に申し訳ありません。

    やはりエクセルのバージョンなどが問題なのでしょうか?


  • id:Mook
    先のコメントは状況を把握するためのものなので、動作的には変わりません。

    同じ環境で以前は部分的にでも動いていたのなら、今回のエラーの原因は
    修正作業でおかしな変更をした可能性があるので、元のコードに戻してください。

    VBA のステップ実行は出来ますか?(VBE でF8を押しながら実行)
    いわゆるデバッグ作業ですが、ご自身である程度原因解析ができるようになると、
    問題解決がずっと早くなります(たいていの問題は簡単なミスなので)。

    部分的にデータが取れないというのは、原因がわからないですね。
    いろいろなURLでやってみて、すべての先で同様に取れないのでしょうか。

    先にアップされたEXCELのURLは、下記の環境でこちらではすべての情報が入るのですが。
    Windows XP + Office2007 + IE6
    Windows Vista + Office2007 + IE7
    今のところ、目途が立ちません・・・。

    先のEXCELにマクロを置き、動作させて部分的に動いた状態(問題のデータが入らない状況)で、
    ファイルをアップいただくことは可能ですか。
  • id:aiomock
    Mook さん

    ご連絡遅れ申し訳ありません。

    アップさせていただきました。

    http://oskuni7.sakura.ne.jp/hatena/question8/query.xls

    時間があるときでよろしいですのでお願いいたします。

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

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

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

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