VBA 从 HTML 网站拉取或提取数据时出现代码错误

Question

我尝试使用 VBA 代码将数据从 HTML 元素提取或拉入 Excel：https://drive.google.com/file/d/1_fGBlOLzMxmV3r-WwC8klcBNB7wUuJN2/view?usp=sharing

我的想法是从 HTML 网站提取和提取黄色突出显示的汇率数据：https://drive.google.com/file/d/1LACA6quFz_Am6mGVjGQ39xvehtX1sybB/view?usp=sharing

不幸的是，当我尝试运行代码时，它编译错误为 "run-time error 445" 和 "object doesn't support this action"

感谢有人能指导我找出错误所在。下面是我的完整 VBA 代码：

Sub ExchangeRate()
Dim ieObj As InternetExplorer
Dim htmlEle As IHTMLElement
Dim htmlEleCollection As IHTMLElementCollection
Dim i As Integer

i = 1

Set ieObj = New InternetExplorer
ieObj.Visible = True
ieObj.navigate "https://secure.mas.gov.sg/msb/ExchangeRatesFeed.aspx?currency=jpy"

While ieObj.readyState <> 4 Or ieObj.Busy: DoEvents: Wend

Set htmlEleCollection = ieObj.document.getElementsByClassName("paditembox").Item(0).getElementsById("item").Value

For Each htmlEle In htmlEleCollection
    If htmlEle.Children.Length > 1 Then

       With ActiveSheet
           .Range("A" & i).Value = htmlEle.Children(0).textContent
           .Range("B" & i).Value = htmlEle.Children(1).textContent
           .Range("C" & i).Value = htmlEle.Children(2).textContent
           .Range("D" & i).Value = htmlEle.Children(3).textContent
           .Range("E" & i).Value = htmlEle.Children(4).textContent
           .Range("F" & i).Value = htmlEle.Children(5).textContent
           .Range("G" & i).Value = htmlEle.Children(6).textContent
       End With
    End If

    i = i + 1

Next htmlEle
End Sub

新正则表达式VBA代码如下：

Public Sub ExchangeRate()
    Dim results(), matches As Object, s As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://eservices.mas.gov.sg/api/action/datastore/search.json?resource_id=5aa64bc2-d234-43f3-892e-2f587a220f74&fields=end_of_week,usd_sgd,jpy_sgd_100&limit=1&sort=end_of_week%20desc", False
        .send
        s = .responseText
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = False

        If .Pattern = "usd_sgd"":""(.*?)""" Then
           .MultiLine = True
           Set matches = .Execute(s)
           ReDim results(1 To matches.Count)

         ElseIf .Pattern = "jpy_sgd_100"":""(.*?)""" Then
            .MultiLine = True
            Set matches = .Execute(s)
            ReDim results(1 To matches.Count)
         End If

   End With
   Dim match As Variant, r As Long
   For Each match In matches
       r = r + 1
       results(r) = match.submatches(0)
   Next
   With ThisWorkbook.Worksheets("Sheet1")
       .Cells(2, 2).Resize(UBound(results), 1) = Application.Transpose(results)
       .Cells(2, 3).Resize(UBound(results), 1) = Application.Transpose(results)
   End With
End Sub

Answer 1

如果我没看错，下面应该会为您获取您想从中获取的内容。

Sub fetchData()
    Const Url = "https://secure.mas.gov.sg/msb/ExchangeRatesFeed.aspx?currency=jpy"
    Dim oItem As Object, Xdoc As New DOMDocument, R&

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", Url, False
        .send
        Xdoc.LoadXML .responseText
    End With

    For Each oItem In Xdoc.getElementsByTagName("item")
        R = R + 1: Cells(R, 1) = oItem.getElementsByTagName("description")(0).Text
    Next oItem
End Sub

要添加到库中的引用：

Microsoft HTML Object Library

这是上述脚本产生的输出类型：

100 Japanese Yen buys 1.3006 Singapore Dollars
100 Japanese Yen buys 1.3001 Singapore Dollars
100 Japanese Yen buys 1.2986 Singapore Dollars
100 Japanese Yen buys 1.2887 Singapore Dollars
100 Japanese Yen buys 1.2857 Singapore Dollars
100 Japanese Yen buys 1.2726 Singapore Dollars
100 Japanese Yen buys 1.2773 Singapore Dollars

您可以像这样进行字符串操作：

For Each oItem In Xdoc.getElementsByTagName("item")
    R = R + 1: Cells(R, 1) = Split(Split(oItem.getElementsByTagName("description")(0).Text, "buys ")(1), " ")(0)
Next oItem

或应用正则表达式从上述结果中挖出所需的部分。

VBA 从 HTML 网站拉取或提取数据时出现代码错误

VBA code error on pull or extract data from HTML website

navigateurl

web-scraping

getelementsbyclassname

web-scraping-language