web-dev-qa-db-ja.com

VBAでHTMLコンテンツを解析する

HTML解析に関連する質問があります。いくつかの製品を含むWebサイトがあり、ページ内のテキストを現在のスプレッドシートに取り込みたいと考えています。このスプレッドシートは非常に大きいですが、3列目にItemNbrが含まれています。14列目のテキストと1行が1つの製品（アイテム）に対応することを期待しています。

私のアイデアは、Innertext afterタグ内にあるWebページの「マテリアル」を取得することです。 ID番号は、ページごとに（時々）変更されます。

ウェブサイトの構造は次のとおりです。

<div style="position:relative;">
    <div></div>
    <table id="list-table" width="100%" tabindex="1" cellspacing="0" cellpadding="0" border="0" role="grid" aria-multiselectable="false" aria-labelledby="gbox_list-table" class="ui-jqgrid-btable" style="width: 930px;">
        <tbody>
            <tr class="jqgfirstrow" role="row" style="height:auto">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="1" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="2" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="3" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="4" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="5" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="6" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="7" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td role="gridcell" style="padding-left:10px" title="Material" aria-describedby="list-table_">Material</td>
                <td role="gridcell" style="" title="600D polyester." aria-describedby="list-table_">600D polyester.</td>
            </tr>           
            <tr ...>
            </tr>
        </tbody>
    </table> </div>

その結果、「600Dポリエステル」を入手したいと思います。

私の（動作していない）コードスニペットはそのままです：

Sub ParseMaterial()

    Dim Cell As Integer
    Dim ItemNbr As String

    Dim AElement As Object
    Dim AElements As IHTMLElementCollection
Dim IE As MSXML2.XMLHTTP60
Set IE = New MSXML2.XMLHTTP60

Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLBody As MSHTML.HTMLBody

Set HTMLDoc = New MSHTML.HTMLDocument
Set HTMLBody = HTMLDoc.body

For Cell = 1 To 5                            'I iterate through the file row by row

    ItemNbr = Cells(Cell, 3).Value           'ItemNbr isin the 3rd Column of my spreadsheet

    IE.Open "GET", "http://www.example.com/?item=" & ItemNbr, False
    IE.send

    While IE.ReadyState <> 4
        DoEvents
    Wend

    HTMLBody.innerHTML = IE.responseText

    Set AElements = HTMLDoc.getElementById("list-table").getElementsByTagName("tr")
    For Each AElement In AElements
        If AElement.Title = "Material" Then
            Cells(Cell, 14) = AElement.nextNode.value     'I write the material in the 14th column
        End If
    Next AElement

        Application.Wait (Now + TimeValue("0:00:2"))

Next Cell

ご協力いただきありがとうございます ！

vbaparsingexcel-vbahtml-parsingweb-crawler
12
Tdev

うまくいけば、あなたを正しい方向に導くことができます。

  • 少しクリーンアップ：readystateプロパティのテストループを削除します。このコンテキストでは、readystateプロパティによって返される値は変更されません。コードは、送信命令の後に一時停止し、サーバーの応答が受信されるか、失敗した場合にのみ再開します。それに応じて、readystateプロパティが設定され、コードの実行が再開されます。まだ準備完了状態をテストする必要がありますが、ループは不要です

  • 適切なHTML要素をターゲットにする：tr要素を検索しています-コードでこれらの要素を使用する方法のロジックは、実際にはtd要素を指しているように見えます

  • プロパティを使用しているオブジェクトで実際に使用できることを確認してください。これを支援するために、すべての変数を汎用オブジェクトではなく特定のオブジェクトとして宣言してください。これにより、インテリセンスが有効になります。最初に関連ライブラリで定義されているオブジェクトの実際の名前を見つけるのが難しい場合は、汎用オブジェクトとして宣言し、コードを実行してから、typename（your_object）を印刷してオブジェクトのタイプを調べますたとえば、デバッグウィンドウに。これはあなたの道にあなたを置く必要があります

また、役立つかもしれないいくつかのコードを以下に含めました。それでもこれを機能させることができず、URLを共有できる場合は、plzを実行します。

Sub getInfoWeb()

    Dim cell As Integer
    Dim xhr As MSXML2.XMLHTTP60
    Dim doc As MSHTML.HTMLDocument
    Dim table As MSHTML.HTMLTable
    Dim tableCells As MSHTML.IHTMLElementCollection

    Set xhr = New MSXML2.XMLHTTP60

    For cell = 1 To 5

        ItemNbr = Cells(cell, 3).Value

        With xhr

            .Open "GET", "http://www.example.com/?item=" & ItemNbr, False
            .send

            If .readyState = 4 And .Status = 200 Then
                Set doc = New MSHTML.HTMLDocument
                doc.body.innerHTML = .responseText
            Else
                MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
                vbNewLine & "HTTP request status: " & .Status
            End If

        End With

        Set table = doc.getElementById("list-table")
        Set tableCells = table.getElementsByTagName("td")

        For Each tableCell In tableCells
            If tableCell.getAttribute("title") = "Material" Then
                Cells(cell, 14).Value = tableCell.NextSibling.innerHTML
            End If
        Next tableCell

    Next cell

End Sub

編集：以下のコメントで提供した詳細情報へのフォローアップとして-追加した追加コメント

'Determine your product number
    'Open an xhr for your source url, and retrieve the product number from there - search for the tag which
    'text include the "productnummer:" substring, and extract the product number from the outerstring
    'OR
    'if the product number consistently consists of the fctkeywords you are entering in your source url
    'with two "0" appended - just build the product number like that
'Open an new xhr for this url "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2productspec-ajax.p?itemc=" & product_number & "&_search=false&rows=-1&page=1&sidx=&sord=asc"
'Load the response in an XML document, and retrieve the material information

Sub getInfoWeb()

    Dim xhr As MSXML2.XMLHTTP60
    Dim doc As MSXML2.DOMDocument60
    Dim xmlCell As MSXML2.IXMLDOMElement
    Dim xmlCells As MSXML2.IXMLDOMNodeList
    Dim materialValueElement As MSXML2.IXMLDOMElement

    Set xhr = New MSXML2.XMLHTTP60

        With xhr

            .Open "GET", "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2productspec-ajax.p?itemc=10031700&_search=false&rows=-1&page=1&sidx=&sord=asc", False
            .send

            If .readyState = 4 And .Status = 200 Then
                Set doc = New MSXML2.DOMDocument60
                doc.LoadXML .responseText
            Else
                MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
                vbNewLine & "HTTP request status: " & .Status
            End If

        End With

        Set xmlCells = doc.getElementsByTagName("cell")

        For Each xmlCell In xmlCells
            If xmlCell.Text = "Materiaal" Then
                Set materialValueElement = xmlCell.NextSibling
            End If
        Next

        MsgBox materialValueElement.Text

End Sub

EDIT2：IEを自動化する代替手段

Sub searchWebViaIE()
    Dim ie As SHDocVw.InternetExplorer
    Dim doc As MSHTML.HTMLDocument
    Dim anchors As MSHTML.IHTMLElementCollection
    Dim anchor As MSHTML.HTMLAnchorElement
    Dim prodSpec As MSHTML.HTMLAnchorElement
    Dim tableCells As MSHTML.IHTMLElementCollection
    Dim materialValueElement As MSHTML.HTMLTableCell
    Dim tableCell As MSHTML.HTMLTableCell

    Set ie = New SHDocVw.InternetExplorer

    With ie
        .navigate "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2facetmain.p?fctkeywords=100317&world=general#tabs-4"
        .Visible = True

        Do While .readyState <> READYSTATE_COMPLETE Or .Busy = True
            DoEvents
        Loop

        Set doc = .document

        Set anchors = doc.getElementsByTagName("a")

        For Each anchor In anchors
            If InStr(anchor.innerHTML, "Product Specificatie") <> 0 Then
                anchor.Click
                Exit For
            End If
        Next anchor

        Do While .readyState <> READYSTATE_COMPLETE Or .Busy = True
            DoEvents
        Loop

    End With

    For Each anchor In anchors
        If InStr(anchor.innerHTML, "Product Specificatie") <> 0 Then
            Set prodSpec = anchor
        End If
    Next anchor

    Set tableCells = doc.getElementById("list-table").getElementsByTagName("td")

    If Not tableCells Is Nothing Then
        For Each tableCell In tableCells
            If tableCell.innerHTML = "Materiaal" Then
                Set materialValueElement = tableCell.NextSibling
            End If
        Next tableCell
    End If

    MsgBox materialValueElement.innerHTML

End Sub
9
IAmDranged

テーブルやExcelとは関係ありません（MS-Access 2013を使用しています）が、トピックタイトルに直接関係しています。私の解決策は

Private Sub Sample(urlSource)
Dim httpRequest As New WinHttpRequest
Dim doc As MSHTML.HTMLDocument
Dim tags As MSHTML.IHTMLElementCollection
Dim tag As MSHTML.HTMLHtmlElement
httpRequest.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible;MSIE 7.0; Windows NT 6.0)"
httpRequest.Open "GET", urlSource
httpRequest.send ' fetching webpage
Set doc = New MSHTML.HTMLDocument
doc.body.innerHTML = httpRequest.responseText
Set tags = doc.getElementsByTagName("a")
i = 1
For Each tag In tags
  Debug.Print i
  Debug.Print tag.href
  Debug.Print tag.innerText
  'Debug.Print tag.Attributes("any other attributes you need")() ' may return an object
  i = i + 1
  If i Mod 50 = 0 Then Stop
  ' or code to store results in a table
Next
End Sub
0
Jean-Marc