使用 VBA 将文本从网站拉入 Excel

Question

我正在慢慢探索是否可以使用 VBA 编写一个宏，该宏将从 A 列中的关键字/代码列表中搜索网站并提取数据。目前，下面的代码仅使用（“A1”）中的范围搜索所需的网站，但确实使用我希望提取的数据到达正确的页面。在这种情况下，a1 中的代码是100-52-7

Sub BrowseToSite()

Dim IE As New SHDocVw.InternetExplorer
Dim HTMLDoc As MSHTML.HTMLDocument

IE.Visible = True
IE.Navigate "https://apps.who.int/food-additives-contaminants-jecfa-database/Search.aspx"

Do While IE.ReadyState <> READYSTATE_COMPLETE
Loop

IE.Document.forms("form1").Elements("ctl00$ContentPlaceHolder1$txtSearch").Value = Range("a1").Value
IE.Document.forms("form1").Elements("ctl00$ContentPlaceHolder1$btnSearch").Click

Set HTMLDoc = IE.Document
'Sheet1.Range("B1").Value = HTMLDoc.getElementsByClassName("sectionHead1")(0).innerText


End Sub

现在我希望将此页面上的“0-5 mg/kg bw (1996)”短语提取到 Excel 中。我计划通过检索类名中的内部文本来做到这一点，但是我遇到了错误Object Variable or With Block variable not set，其中包含以下行：

Sheet1.Range("B1").Value = HTMLDoc.getElementsByClassName("sectionHead1")(0).innerText

Answer 1

您可以完全摆脱 IE 并尝试使用 xmlhttp 请求来使脚本更加健壮。以下脚本的作用是首先发送一个 get http 请求来抓取应该在 post 请求中使用的某些参数的值，然后发出一个 post 请求来解析所需的内容。

这是一种有效的方法：

Option Explicit
Public Sub GetContent()
    Const Url = "https://apps.who.int/food-additives-contaminants-jecfa-database/Search.aspx"
    Dim oHttp As Object, oHtml As HTMLDocument, MyDict As Object
    Dim DictKey As Variant, payload$, searchKeyword$
    
    Set oHtml = New HTMLDocument
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set MyDict = CreateObject("Scripting.Dictionary")
    
    'send get requests first to parse the value of "__VIEWSTATE", "__VIEWSTATEGENERATOR" e.t.c., as in oHtml.getElementById("__VIEWSTATE").Value
    
    With oHttp
        .Open "GET", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
        .send
        oHtml.body.innerHTML = .responseText
    End With
    
    searchKeyword = "100-52-7" 'this is the search keyword you wanna use from your predefined search terms
    
    'MyDict stores keys and values within dictionary, as in __VIEWSTATE = "some value" and so on
    
    MyDict("__VIEWSTATE") = oHtml.getElementById("__VIEWSTATE").Value
    MyDict("__VIEWSTATEGENERATOR") = oHtml.getElementById("__VIEWSTATEGENERATOR").Value
    MyDict("__EVENTVALIDATION") = oHtml.getElementById("__EVENTVALIDATION").Value
    MyDict("ctl00$ContentPlaceHolder1$txtSearch") = searchKeyword
    MyDict("ctl00$ContentPlaceHolder1$btnSearch") = "Search"
    MyDict("ctl00$ContentPlaceHolder1$txtSearchFEMA") = ""

    'joining each set of key and value with ampersand to make it a string so that you can use it as a parameter while issuing post requests, which is what payload is doing
    
    payload = ""
    For Each DictKey In MyDict
        payload = IIf(Len(DictKey) = 0, WorksheetFunction.encodeURL(DictKey) & "=" & WorksheetFunction.encodeURL(MyDict(DictKey)), _
        payload & "&" & WorksheetFunction.encodeURL(DictKey) & "=" & WorksheetFunction.encodeURL(MyDict(DictKey)))
    Next DictKey
    
    With oHttp
        .Open "POST", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
        .setRequestHeader "Content-type", "application/x-www-form-urlencoded"
        .send (payload)
        oHtml.body.innerHTML = .responseText
    End With
    
    MsgBox oHtml.querySelector("#SearchResultItem > a").NextSibling.NodeValue
    
End Sub

确保添加以下库来执行上述脚本：

Microsoft XML, v6.0
Microsoft Scripting Runtime
Microsoft HTML Object Library

Answer 2

你用这行代码点击一个元素：

IE.Document.forms("form1").Elements("ctl00$ContentPlaceHolder1$btnSearch").Click

IE 发出 POST 请求以检索您的结果，如下所示：

^{以上是 Edge 开发工具的截图，但概念是一样的}

在此请求期间，相关元素不会立即出现，因此您需要等待它加载。

你之前的方法

Do While IE.ReadyState <> READYSTATE_COMPLETE
Loop

可能会起作用，但我发现它有时会不一致，并且还包括检查 .Busy 属性。

点击后尝试使用它：

IE.Document.forms("form1").Elements("ctl00$ContentPlaceHolder1$btnSearch").Click

'~~WAIT FOR SEARCH RESULTS TO LOAD~~
Do While IE.ReadyState < READYSTATE_COMPLETE Or IE.Busy
Loop

Set HTMLDoc = IE.Document
Sheet1.Range("B1").Value = HTMLDoc.getElementsByClassName("sectionHead1")(0).innerText

---

如果您仍然遇到问题，您可以强制 IE 等待相关元素变为可用，方法是这样做：

On Error Resume Next
Do while HTMLDoc.getElementsByClassName("sectionHead1")(0) is Nothing
Loop
On Error Goto 0

Set HTMLDoc = IE.Document
Sheet1.Range("B1").Value = HTMLDoc.getElementsByClassName("sectionHead1")(0).innerText

这是一个检查对象的简单循环，并将继续循环直到该对象不再是Nothing（这实际上意味着它已加载）。

我建议您添加某种可能触发错误的超时，以防万一网页出现问题，以免您处于无限循环中。

专业提示：

如果您多次单击搜索按钮并等待 加载很多对象，而不是复制上面的代码，你可以 把它变成它自己的子并做类似的事情：

Sub WaitForElement(IE as InternetExplorer, elem As Object)
    
    Do While IE.ReadyState < 4 Or IE.Busy: Loop

    On Error Resume Next
    Do While elem is Nothing: Loop
    On error Goto 0

End Sub

那么您只需在每次点击后使用以下行：

WaitForElement IE, HTMLDoc.getElementsByClassName("sectionHead1")(0)

这不仅会减少代码中的行数，还可以大大提高可读性。