VBA串接GetUrl与GetData模块 批量循环查询ECHA化学品数据

解决方案 #

你的思路完全可行，之前搜索到的「VBA不支持嵌套函数」是误解，VBA仅不支持在函数/过程内部定义另一个函数/过程，函数之间的互相调用是完全允许的。
你只需要把两个原本硬编码绑定固定单元格的逻辑，改成参数传递的形式，再外层加一个遍历行的主循环即可，具体修改如下：

步骤1：重构GetUrl函数，支持传入物质名和CAS号 #

不再硬编码读取A1/B1单元格，改为通过参数接收查询条件，适配任意行的数据：

Public Function GetUrl(ByVal SubstanceName As String, ByVal CASNumber As String) As String
    Const Url = "https://echa.europa.eu/information-on-chemicals/registered-substances?p_p_id=dissregisteredsubstances_WAR_dissregsubsportlet&p_p_lifecycle=1&p_p_state=normal&p_p_mode=view&_dissregisteredsubstances_WAR_dissregsubsportlet_javax.portlet.action=dissRegisteredSubstancesAction"
    
    Dim oHtml As HTMLDocument, oHttp As Object, MyDict As Object
    Dim DictKey As Variant, payload As String
    Set oHtml = New HTMLDocument
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set MyDict = CreateObject("Scripting.Dictionary")
        
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_name") = SubstanceName
    MyDict("_dissregisteredsubstances_WAR_dissregsubsportlet_disreg_cas-number") = CASNumber
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimer") = "true"
    MyDict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimerCheckbox") = "on"
    
    payload = vbNullString
        
    For Each DictKey In MyDict
        payload = IIf(Len(payload) = 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
        
    GetUrl = oHtml.querySelector(".details").getAttribute("href")
    Debug.Print oHtml.querySelector(".substanceNameLink ").innerText
    Debug.Print GetUrl
End Function

步骤2：重构GetData过程，支持传入URL和目标行号 #

不再直接调用GetUrl，改为通过参数接收查询URL，同时传入当前处理的行号，把抓取到的DNEL值直接写入对应行的单元格：

Sub GetData(ByVal TargetUrl As String, ByVal RowNum As Long)
    Dim XMLReq As New MSXML2.XMLHTTP60
    Dim HTMLDoc As New MSHTML.HTMLDocument
    Dim Route(1 To 3) As String
    Dim c As Long, Info As Object, Data As Object

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

    XMLReq.Open "Get", TargetUrl & "/7/1", False
    XMLReq.send
 
    If XMLReq.Status <> 200 Then
        MsgBox "请求错误" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
        Exit Sub
    End If
 
    HTMLDoc.body.innerHTML = XMLReq.responseText

    ' 循环写入3种暴露途径的DNEL值到当前行的C、D、E列
    For c = 1 To UBound(Route, 1)
        Set Info = HTMLDoc.getElementById(Route(c))
        Debug.Print Info.innerText
        Set Info = Info.NextSibling.NextSibling.NextSibling
        Set Data = Info.getElementsByTagName("dd")(1)
        Debug.Print Data.innerText
        Cells(RowNum, c + 2) = Data.innerText
    Next c
End Sub

步骤3：新增主循环过程，批量遍历所有行 #

遍历A列所有有值的行，逐行调用上面两个函数/过程完成批量查询：

Sub BatchProcess()
    Dim LastRow As Long, i As Long
    Dim SubstanceName As String, CASNumber As String, CurUrl As String
    
    ' 获取A列最后一行有数据的行号
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 从第1行开始遍历，你可以根据表头情况修改起始行（比如有表头就从2开始）
    For i = 1 To LastRow
        SubstanceName = Cells(i, "A").Value
        CASNumber = Cells(i, "B").Value
        ' 跳过物质名和CAS都为空的行
        If Len(SubstanceName) = 0 And Len(CASNumber) = 0 Then GoTo NextRow
        
        ' 先调用GetUrl获取查询地址
        CurUrl = GetUrl(SubstanceName, CASNumber)
        ' 再调用GetData抓取数据写入当前行
        Call GetData(CurUrl, i)
NextRow:
    Next i
    MsgBox "批量查询完成"
End Sub

使用说明 #

1. 先在VBA编辑器的「工具-引用」中勾选以下两个引用，避免运行报错：
   • Microsoft HTML Object Library
   • Microsoft XML, v6.0
2. A列填写物质名、B列填写CAS号（可仅填其中任意一项）
3. 运行BatchProcess过程即可，结果会自动写入对应行的C（吸入DNEL）、D（经皮DNEL）、E（经口DNEL）列。

内容的提问来源于stack exchange，提问作者Nick