Web在VBA中仅抓取网页的特定部分

Posted 2023-03-27

【中文标题】Web在VBA中仅抓取网页的特定部分

【英文标题】：WebScraping only specific sections of a webpage in VBA

【发布时间】：2022-01-11 06:55:24

【问题描述】：

我正在重新审视网络抓取，以尝试开发一种可以从数据库中提取数据的工具。

我在这里使用的物质档案位于：https://echa.europa.eu/registration-dossier/-/registered-dossier/16016/7/1。

这里列出了可以在此档案中找到的各种毒理学信息，但我只对此处称为 DNEL 的出发点值 (POD) 感兴趣：

基本上复制一个答案给我提供了一段时间，我有以下代码来提取第一个 POD。

Public Sub GetContents()
    

'Start ECHA Search via XML HTTP Request

Dim XMLReq As New MSXML2.XMLHTTP60
Dim htmlDoc As New MSHTML.HTMLDocument

XMLReq.Open "Get", "https://echa.europa.eu/registration-dossier/-/registered-dossier/16016/7/1", False
XMLReq.send
 
If XMLReq.Status <> 200 Then
        
    MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
    Exit Sub

    End If
 
HTMLDoc.body.innerHTML = XMLReq.responseText


'Retrieve Data

'POD Population and Route
Set Info = HTMLDoc.getElementById("sWorkersHazardViaInhalationRoute")

Debug.Print Info.innerText

'POD Type
Set Info = HTMLDoc.getElementsByClassName("HorDL")(0)
Set data = Info.getElementsByTagName("dd")(0)
Debug.Print data.innerText

'POD Value
Set data = Info.getElementsByTagName("dd")(1)
Debug.Print data.innerText

End Sub

这可以为第一个管理途径拉取 POD：WorkersHazardViaDermalRoute

Workers - Hazard via inhalation route
DNEL (Derived No Effect Level)
238 mg/m³

这很好，但我真的希望能够对其进行调整，以提取 DNEL 及其对每种给药途径的价值。此处以蓝色突出显示：

因此，对于这个示例，整个所需的输出将跨越 3 列（虽然只是想提取数据，但它现在在 3 列中并不重要）：

Workers - Hazard via inhalation route, DNEL (Derived No Effect Level), 238 mg/m³
Workers - Hazard via dermal route, DNEL (Derived No Effect Level), 84 mg/kg bw/day
General Population - Hazard via inhalation route, DNEL (Derived No Effect Level), 70 mg/m³
General Population - Hazard via dermal route, DNEL (Derived No Effect Level), 51 mg/kg bw/day
General Population - Hazard via oral route, DNEL (Derived No Effect Level), 24 mg/kg bw/day

我遇到的问题是我正在使用类元素“HorDL”来获取此信息，但不幸的是，该类不仅限于每条路线以蓝色突出显示的部分。所以 ("HorDL")(0) 可以找到，但是 ("HorDL")(1) 会立即在下面提取相同路线的信息。

出于这个原因，我怀疑使用这个类元素来提取信息并不是最好的方法，但是我想不出任何其他方法来做到这一点。

我已经有办法提取相关的档案，所以如果这可行，它将成为一个只提取相关信息的 Neat 工具。我考虑过提取所有信息，然后在 excel 中应用过滤器，但我认为这不是一个特别优雅的解决方案。

非常感谢任何回复。

【问题讨论】：

所有 DNEL 是否与其他档案一致，或者最好从毒理学摘要中确定所有可用的 DNEL（不包括 Additional Information 和 Hazard for the eyes 的那些）？

@Raymond Wu 最好从可用的内容中确定。

在下面试试我的答案，看看它是否适合你。

【参考方案1】：

这假设您只想要标题中带有关键字Workers 和General Population 的DNEL，其中排除带有Hazard for the eyes 的DNEL

注意：您应该声明所有变量，在模块顶部插入 Option Explicit 以帮助您执行它。

Option Explicit

Public Sub GetContents()
    Const DNELTitle As Long = 1
    Const DNELAssessment As Long = 2
    Const DNELValue As Long = 3
    
    Const resultFirstCell As String = "A1" 'Change the first cell address to insert the result accordingly
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change worksheet name accordingly
    
    'Start ECHA Search via XML HTTP Request
    Dim XMLReq As New MSXML2.XMLHTTP60
    Dim HTMLDoc As New MSHTML.HTMLDocument
    
    XMLReq.Open "Get", "https://echa.europa.eu/registration-dossier/-/registered-dossier/16016/7/1", False
    XMLReq.send
     
    If XMLReq.Status = 200 Then
        HTMLDoc.body.innerHTML = XMLReq.responseText
        
        '==== Loop through each anchors and get the relevant ID for interested DNEL
        Dim anchors As Object
        Set anchors = HTMLDoc.getElementById("SectionAnchors")
        Set anchors = anchors.getElementsByTagName("a")
        
        Dim anchorsColl As Collection
        Set anchorsColl = New Collection
        
        Dim i As Long
        For i = 0 To anchors.Length - 1
            Dim anchorText As String
            anchorText = anchors(i).innerText
            
            If InStr(anchorText, "Workers - ") <> 0 Or _
                InStr(anchorText, "General Population - ") <> 0 Then
                
                If InStr(anchorText, "Additional Information") = 0 And _
                    InStr(anchorText, "Hazard for the eyes") = 0 Then
                    
                    anchorsColl.Add Replace(anchors(i).href, "about:blank#", vbNullString)
                End If
            End If
        Next i
        '====
        
        If anchorsColl.Count <> 0 Then
            Dim outputArr() As String
            ReDim outputArr(1 To anchorsColl.Count, 1 To 3) As String
            
            For i = 1 To anchorsColl.Count
                Dim anchorEle As Object
                                
                Set anchorEle = HTMLDoc.getElementById(anchorsColl(i))
                outputArr(i, DNELTitle) = anchorEle.innerText
                
                'Loop through the anchor's sibling until it finds the DL tag to extract the values
                Do While anchorEle.nodeName <> "DL"
                    Set anchorEle = anchorEle.NextSibling
                Loop
                
                'Assumes that the assessment conclusion is in the first DD tag
                'Assumes that the value is in the second DD tag
                outputArr(i, DNELAssessment) = anchorEle.getElementsByTagName("dd")(0).innerText
                outputArr(i, DNELValue) = anchorEle.getElementsByTagName("dd")(1).innerText
            Next i
            
            'Write the extraction result to the worksheet starting from A1
            ws.Range(resultFirstCell).Resize(UBound(outputArr, 1), 3).Value = outputArr
        Else
            Debug.Print "No DNEL found."
        End If
        
        Set ws = Nothing
        Set HTMLDoc = Nothing
    Else
        MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
    End If
    
    Set XMLReq = Nothing
End Sub

【讨论】：

我在尝试测试此代码时收到错误“无效使用 null”。调试亮点 For i = 0 To anchors.Length - 1 作为问题

@Nick 不完全确定原因，但也许您的 MSHTML 库不喜欢 querySelectorAll。我已将其编辑为另一种方法，因此请尝试编辑后的代码。

您的两个脚本都在 excel 2016 @Raymond Wu 中完美运行。

@SIM 感谢您对此进行测试，我在 Excel 2019 和 11.0.17763.2300 上用于 MSHTML.dll（这可能与 querySelector/querySelectorAll 的行为不同，具体取决于 dll 的版本文件）

是的，没错。它的发生是因为空格。抛出Invalid use of null 的那个需要声明为mshtml.IHTMLDOMChildrenCollection 而不是Object。

【参考方案2】：

到目前为止我自己的答案。

接下来，我将循环遍历一个值列表，以返回每个值的 DNEL。还需要包含某种错误处理。

Sub GetData()
    

'Start ECHA Search via XML HTTP Request

Dim XMLReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument

XMLReq.Open "Get", "https://echa.europa.eu/registration-dossier/-/registered-dossier/16016/7/1", False
XMLReq.send
 
If XMLReq.Status <> 200 Then
        
    MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
    Exit Sub

    End If
 
HTMLDoc.body.innerHTML = XMLReq.responseText


'Retrieve Data for General population

'Defines class element for each route
Dim Route(1 To 3) As String

Route(1) = "sGeneralPopulationHazardViaInhalationRoute"
Route(2) = "sGeneralPopulationHazardViaDermalRoute"
Route(3) = "sGeneralPopulationHazardViaOralRoute"

'Loops through each element

r = 4
c = 6

Dim i As Long

For i = 1 To UBound(Route, 1)


Set Info = HTMLDoc.getElementById(Route(i))
Debug.Print Info.innerText

Set Info = HTMLDoc.getElementById(Route(i)).NextSibling.NextSibling.NextSibling
Set Data = Info.getElementsByTagName("dd")(0)
Debug.Print Data.innerText

Set Data = Info.getElementsByTagName("dd")(1)
Debug.Print Data.innerText


Cells(r, c) = Data.innerText

c = c + 1

Next i

r = r + 1


End Sub