VBA-Web Scraping-无法访问表格网页

Question

我试图在这个网站https://www.energylive.cloud/ 中抓取数据价格表，就像我在其他网站上所做的那样，但我不能（我没有太多抓取经验）。提前致谢！！！：

Sub ej()

Dim XMLrequest As New MSXML2.XMLHTTP60
Dim HTMLdoc As New MSHTML.HTMLDocument
Dim HTMLtable As MSHTML.IHTMLElement
'Dim HTMLi As MSHTML.IHTMLElementCollection


Dim url As String

url = "https://www.energylive.cloud/"

XMLrequest.Open "GET", url, False   
XMLrequest.send

If XMLrequest.Status <> 200 Then    
    MsgBox XMLrequest.Status & XMLrequest.statusText
End If

HTMLdoc.body.innerHTML = XMLrequest.responseText

'debug.print htmldoc.body.innerText    'I checked here but the table is not here

Set HTMLtable = HTMLdoc.getElementById("price_table")


    'Debug.Print HTMLtable.ID


End Sub

Answer 1

您要查找的内容在该页面中不可用。它是动态添加的。这是the link，您可以在其中找到所需的静态内容，您可以使用 xhr 抓取这些内容。要找到该链接，您需要使用 chrome 开发工具或类似工具。打开开发工具后，选择网络选项卡，然后尝试重新加载页面以观察 All 或 xhr 内的网络活动，您应该可以在其中找到该链接。

从 json 响应中解析出所需的内容并不容易，尤其是当您使用 vba 时，因为没有这样的内置库来帮助您获取它们。不过，更常见的方法是使用任何第三方 json 转换器。

但是，我在这里使用了正则表达式，它似乎完美地抓取了数据。当你运行脚本时，你应该眨眼之间就得到了所有的表格内容。

Sub FetchTabularData()
    Const mainUrl$ = "https://www.energylive.cloud/pwr-hour/get-index-averages?callback=%3F"
    Dim I&, S$, Elem As Object, subElemName As Object
    Dim subElemChange As Object, subElemPrice As Object
    Dim subElemMtd As Object, subElemYtd As Object, R As Long: R = 1
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", mainUrl, False
        .send
        S = .responseText
    End With
    
    ws.Range("A1:E1") = [{"Index","Value","Changes","Month To Date","Year To Date"}]
    
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True

        .Pattern = "\[?{[\s\S]+?\},?"
        Set Elem = .Execute(S)
        For I = 0 To Elem.count - 1
            .Pattern = "Index""\:""(.*?)"","
            Set subElemName = .Execute(Elem(I))
            .Pattern = "Value""\:""(.*?)\"","
            Set subElemPrice = .Execute(Elem(I))
            .Pattern = "Perc""\:""(.*?)"","
            Set subElemChange = .Execute(Elem(I))
            .Pattern = "Month-to-date""\:""(.*?)"","
            Set subElemMtd = .Execute(Elem(I))
            .Pattern = "Year-to-date""\:""(.*?)"""
            Set subElemYtd = .Execute(Elem(I))

            R = R + 1: ws.Cells(R, 1) = subElemName(0).submatches(0)
            ws.Cells(R, 2) = subElemPrice(0).submatches(0)
            ws.Cells(R, 3) = subElemChange(0).submatches(0) & "%"
            ws.Cells(R, 4) = subElemMtd(0).submatches(0)
            ws.Cells(R, 5) = subElemYtd(0).submatches(0)
        Next I
    End With
End Sub

PS 你不需要添加对库的任何引用来执行上述脚本。只需确保您的 Excel 工作簿中有一个名为 Sheet1 的工作表即可。