webサイトからマクロでデータを抽出して

エクセル形式のデータを得たいです。
具体的ページとして
https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100
となります。

理想形として
題名、開催地、期間、概要
の4つのカラムで下に向かってデータが並ぶものを理想としています。

VBAはほぼ初心者で困ってしまっています。
よろしくお願いします。

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2015/11/16 15:32:57
  • 終了:2015/11/19 14:25:40

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4367ベストアンサー獲得回数18032015/11/16 16:37:21

ポイント1000pt

こんな感じで。
アクティブなシートの 2行目から、題名、開催地、期間、概要を書きだします。

Sub 展示会情報を抽出()
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    URL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
        Set doc = CreateObject("htmlfile")
        doc.write xhr.responseText
        Set divList = doc.getElementsByTagName("DIV")
        For i = 0 To divList.Length - 1
            r = 2   ' 一行目はタイトル行
            If divList(i).className = "elem_text_list_news" Then
                Set Item = divList(i).FirstChild
                Do While Not Item Is Nothing
                    Set Data = Item.getElementsByTagName("DD")
                    Set Title = Data(0).FirstChild
                    Set eventDate = Title.NextSibling
                    Set place = eventDate.NextSibling
                    Set Comment = place.NextSibling
                    Cells(r, 1).Value = title.innerText
                    Cells(r, 2).Value = place.innerHTML
                    Cells(r, 3).Value = eventDate.innerHTML
                    Cells(r, 4).Value = comment.innerHTML

                    Set Item = Item.NextSibling
                    r = r + 1
                    If r > 200 Then     ' 念のため
                        Exit For
                    End If
                    DoEvents
                Loop
                Exit For
            End If
            DoEvents
        Next
        Set doc = Nothing
    End If
    Set xhr = Nothing
End Sub






追記です。

欲しいのは日本開催の展示会全部なのですが
それは可能でしょうか?

絞り込んだ地域などをパラメータ渡しではなくセッションで持っているようなので、データの取り方を変えました。
こんな感じです。
「展示会情報を抽出」サブルーチンを呼び出してください。

Sub nav(oIE, sURL)
    oIE.Navigate sURL
    Do While oIE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
End Sub

Function nextElement(e)
    Do While Not e Is Nothing
        If e.NodeType = 1 Then
            Exit Do
        End If
        Set e = e.NextSibling
    Loop
    Set nextElement = e
End Function

Sub 展示会情報を抽出()

    Set oIE = CreateObject("InternetExplorer.Application")

    oIE.Visible = False

    sURL = "https://www.jetro.go.jp/j-messe"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v1&v_2=009"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v2&v_2=009&v_3=002"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■■"

    Set oDoc = oIE.document
    Set vvv = oDoc.querySelectorAll("DIV.elem_text_list_news DD")

    For i = 0 To vvv.Length - 1
        Set data = vvv.Item(i)
        Set Title = nextElement(data.FirstChild)
        Set eventDate = nextElement(Title.NextSibling)
        Set place = nextElement(eventDate.NextSibling)
        Set Comment = nextElement(place.NextSibling)
        r = i + 2
        Cells(r, 1).Value = Title.innerText
        Cells(r, 2).Value = place.innerText
        Cells(r, 3).Value = eventDate.innerText
        Cells(r, 4).Value = Comment.innerText
        Range(Cells(r, 1), Cells(r, 4)).WrapText = False

        DoEvents
    Next

    oIE.Quit
    Set oIE = Nothing
End Sub

最初からページをたどっていくので、かなり遅くなっちゃいました。
最終的な一覧ページにたどり着くのに少々待たされるので、A2 のセルに簡易的に進捗状況を表示するようにしてます。
が四つになると一覧のページにたどり着いています。




追記です。
新しめのメソッドが駄目なのかな、ということで、古くからあるメソッドだけで書き直してみたものです。

Sub nav(oIE, sURL)
    oIE.Navigate sURL
    Do While oIE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
End Sub

Function nextElement(e)
    Do While Not e Is Nothing
        If e.NodeType = 1 Then
            Exit Do
        End If
        Set e = e.NextSibling
    Loop
    Set nextElement = e
End Function

Sub 展示会情報を抽出()

    Set oIE = CreateObject("InternetExplorer.Application")

    oIE.Visible = False

    sURL = "https://www.jetro.go.jp/j-messe"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v1&v_2=009"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v2&v_2=009&v_3=002"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■■"

    Set oDoc = oIE.document
    Set ddList = oDoc.getElementsByTagName("DD")
    r = 2
    For i = 0 To ddList.Length - 1
        If ddList(i).ParentNode.ParentNode.className = "var_ptb10 elem_text_list_news_pad" Then
            Set Data = ddList(i)
            Set Title = nextElement(Data.FirstChild)
            Set eventDate = nextElement(Title.NextSibling)
            Set place = nextElement(eventDate.NextSibling)
            Set Comment = nextElement(place.NextSibling)
            Cells(r, 1).Value = Title.innerText
            Cells(r, 2).Value = place.innerText
            Cells(r, 3).Value = eventDate.innerText
            Cells(r, 4).Value = Comment.innerText
            Range(Cells(r, 1), Cells(r, 4)).WrapText = False
            r = r + 1
        End If
        DoEvents
    Next

    oIE.Quit
    Set oIE = Nothing
End Sub
他5件のコメントを見る
id:used-by-ryo

何度もありがとうございます。

現在、こちらの環境はexcel2013+IE8でした。
まだ、同じく
oDoc.querySelectorAll
の部分でエラーぽいのですが・・・

環境を合わせることを検討してみます

2015/11/17 19:42:32
id:a-kuma3

まだ、同じく
oDoc.querySelectorAll
の部分でエラーぽいのですが・・・

いけない。間違えました。
三番目のコードの querySelectorAll は不必要な行です。
回答を修正して不必要な行を削除しましたので、そちらで試してみてください。

IE8 だと、querySelectorAll は未対応だったような気がします。

2015/11/17 21:01:30

その他の回答(0件)

id:a-kuma3 No.1

a-kuma3回答回数4367ベストアンサー獲得回数18032015/11/16 16:37:21ここでベストアンサー

ポイント1000pt

こんな感じで。
アクティブなシートの 2行目から、題名、開催地、期間、概要を書きだします。

Sub 展示会情報を抽出()
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    URL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    xhr.Open "GET", URL, False
    xhr.send ""
    If xhr.StatusText = "OK" Then
        Set doc = CreateObject("htmlfile")
        doc.write xhr.responseText
        Set divList = doc.getElementsByTagName("DIV")
        For i = 0 To divList.Length - 1
            r = 2   ' 一行目はタイトル行
            If divList(i).className = "elem_text_list_news" Then
                Set Item = divList(i).FirstChild
                Do While Not Item Is Nothing
                    Set Data = Item.getElementsByTagName("DD")
                    Set Title = Data(0).FirstChild
                    Set eventDate = Title.NextSibling
                    Set place = eventDate.NextSibling
                    Set Comment = place.NextSibling
                    Cells(r, 1).Value = title.innerText
                    Cells(r, 2).Value = place.innerHTML
                    Cells(r, 3).Value = eventDate.innerHTML
                    Cells(r, 4).Value = comment.innerHTML

                    Set Item = Item.NextSibling
                    r = r + 1
                    If r > 200 Then     ' 念のため
                        Exit For
                    End If
                    DoEvents
                Loop
                Exit For
            End If
            DoEvents
        Next
        Set doc = Nothing
    End If
    Set xhr = Nothing
End Sub






追記です。

欲しいのは日本開催の展示会全部なのですが
それは可能でしょうか?

絞り込んだ地域などをパラメータ渡しではなくセッションで持っているようなので、データの取り方を変えました。
こんな感じです。
「展示会情報を抽出」サブルーチンを呼び出してください。

Sub nav(oIE, sURL)
    oIE.Navigate sURL
    Do While oIE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
End Sub

Function nextElement(e)
    Do While Not e Is Nothing
        If e.NodeType = 1 Then
            Exit Do
        End If
        Set e = e.NextSibling
    Loop
    Set nextElement = e
End Function

Sub 展示会情報を抽出()

    Set oIE = CreateObject("InternetExplorer.Application")

    oIE.Visible = False

    sURL = "https://www.jetro.go.jp/j-messe"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v1&v_2=009"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v2&v_2=009&v_3=002"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■■"

    Set oDoc = oIE.document
    Set vvv = oDoc.querySelectorAll("DIV.elem_text_list_news DD")

    For i = 0 To vvv.Length - 1
        Set data = vvv.Item(i)
        Set Title = nextElement(data.FirstChild)
        Set eventDate = nextElement(Title.NextSibling)
        Set place = nextElement(eventDate.NextSibling)
        Set Comment = nextElement(place.NextSibling)
        r = i + 2
        Cells(r, 1).Value = Title.innerText
        Cells(r, 2).Value = place.innerText
        Cells(r, 3).Value = eventDate.innerText
        Cells(r, 4).Value = Comment.innerText
        Range(Cells(r, 1), Cells(r, 4)).WrapText = False

        DoEvents
    Next

    oIE.Quit
    Set oIE = Nothing
End Sub

最初からページをたどっていくので、かなり遅くなっちゃいました。
最終的な一覧ページにたどり着くのに少々待たされるので、A2 のセルに簡易的に進捗状況を表示するようにしてます。
が四つになると一覧のページにたどり着いています。




追記です。
新しめのメソッドが駄目なのかな、ということで、古くからあるメソッドだけで書き直してみたものです。

Sub nav(oIE, sURL)
    oIE.Navigate sURL
    Do While oIE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
End Sub

Function nextElement(e)
    Do While Not e Is Nothing
        If e.NodeType = 1 Then
            Exit Do
        End If
        Set e = e.NextSibling
    Loop
    Set nextElement = e
End Function

Sub 展示会情報を抽出()

    Set oIE = CreateObject("InternetExplorer.Application")

    oIE.Visible = False

    sURL = "https://www.jetro.go.jp/j-messe"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v1&v_2=009"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&type=v2&v_2=009&v_3=002"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■"

    sURL = "https://www.jetro.go.jp/j-messe/?action_fairList=true&page=1&limit=100"
    Call nav(oIE, sURL)
    Cells(2, 1).Value = "■■■■"

    Set oDoc = oIE.document
    Set ddList = oDoc.getElementsByTagName("DD")
    r = 2
    For i = 0 To ddList.Length - 1
        If ddList(i).ParentNode.ParentNode.className = "var_ptb10 elem_text_list_news_pad" Then
            Set Data = ddList(i)
            Set Title = nextElement(Data.FirstChild)
            Set eventDate = nextElement(Title.NextSibling)
            Set place = nextElement(eventDate.NextSibling)
            Set Comment = nextElement(place.NextSibling)
            Cells(r, 1).Value = Title.innerText
            Cells(r, 2).Value = place.innerText
            Cells(r, 3).Value = eventDate.innerText
            Cells(r, 4).Value = Comment.innerText
            Range(Cells(r, 1), Cells(r, 4)).WrapText = False
            r = r + 1
        End If
        DoEvents
    Next

    oIE.Quit
    Set oIE = Nothing
End Sub
他5件のコメントを見る
id:used-by-ryo

何度もありがとうございます。

現在、こちらの環境はexcel2013+IE8でした。
まだ、同じく
oDoc.querySelectorAll
の部分でエラーぽいのですが・・・

環境を合わせることを検討してみます

2015/11/17 19:42:32
id:a-kuma3

まだ、同じく
oDoc.querySelectorAll
の部分でエラーぽいのですが・・・

いけない。間違えました。
三番目のコードの querySelectorAll は不必要な行です。
回答を修正して不必要な行を削除しましたので、そちらで試してみてください。

IE8 だと、querySelectorAll は未対応だったような気がします。

2015/11/17 21:01:30
id:used-by-ryo

表記のURLは世界全体の展示情報でしたが
欲しい情報は日本国内の展示会情報です。

https://www.jetro.go.jp/j-messe/
ここから
アジア>日本
と選択していくと行けるところです。

コメントはまだありません

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

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

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

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