Json VBA-HTML抓取问题

我正试图从网站上搜集拍卖数据。我目前的尝试是使用下面的代码将网站的HTML拉入VBA，然后对其进行解析，只保留我想要的物品（拍卖名称、天数、物品数量）

---

它成功地获取了数据，但“即将到来的重型设备拍卖”部分（包含拍卖的所有名称和规模）没有被纳入VBA。一般来说，我对HTML不是很在行，但我希望有人能提供一个解决方案，或者至少解释一下，当我搜索被拉入VBA的网站HTML时，找不到我想要的文章。

所提供链接的网页源HTML不包含必要的数据，它使用AJAX。该网站有一个可用的API。响应以JSON格式返回。浏览页面e。G在Chrome中，然后打开开发者工具窗口（F12），网络选项卡，重新加载（F5）页面并检查记录的XHR。最相关的数据是URL返回的JSON字符串：

您可以使用下面的VBA代码来检索上述信息将模块导入VBA项目以进行JSON处理。

选项显式
子测试
Const Transposed=False“输出选项
暗响应为字符串
Dim vJSON
将状态设置为字符串
我想我会坚持多久
Dim aRows（）
Dim aHeader（）
'检索JSON数据
XmlHttpRequest“获取”https://www.rbauction.com/rba-api/calendar/v1?e1=true，，，，，，，响应
'解析JSON响应
Parse sResponse，vJSON，sState
如果指定“对象”，则
MsgBox“无效的JSON响应”
出口接头
如果结束
“挑选核心数据
vJSON=vJSON（“拍卖”）
'提取每个项目的选定属性
对于i=0到UBound（vJSON）
设置vJSON（i）=提取键（vJSON（i），数组（“eventId”、“name”、“date”、“itemCount”））
多芬特
下一个
'将JSON结构转换为二维数组以进行输出
JSON.ToArray vJSON，aRows，aHeader
"产出",
使用此工作簿。工作表（1）
.Cells.Delete
如果转置，则
Output2DArray.Cells（1,1），WorksheetFunction.Transpose（aHeader）
Output2DArray.Cells（1,2），WorksheetFunction.Transpose（aRows）
其他的
输出阵列。单元格（1，1），A头
Output2DArray.Cells（2，1），aRows
如果结束
.Columns.AutoFit
以
MsgBox“已完成”
端接头
子XmlHttpRequest（sMethod作为字符串，sUrl作为字符串，arrSetHeaders，sFormData，sresheaders作为字符串，sContent作为字符串）
暗棱头
使用CreateObject（“Msxml2.ServerXMLHTTP”）
“.SetOption 2，13056”SXH\u服务器\u证书\u忽略\u所有\u服务器\u错误
使用CreateObject（“MSXML2.XMLHTTP”）
.开放式sMethod，sUrl，False
如果是IsArray（arrSetHeaders），则
对于arrSetHeaders中的每个arrHeader
.SetRequestHeader arrHeader（0），arrHeader（1）
下一个
如果结束
.发送sFormData
sresheaders=.GetAllResponseHeaders
sContent=.responseText
以
端接头
函数提取键（oSource、aKeys、可选oDest=Nothing）作为对象
调暗键
如果oDest为空，则设置oDest=CreateObject（“Scripting.Dictionary”）
对于aKeys中的每个vKey
如果oSource.存在（vKey），则
如果是IsObject（oSource（vKey）），则
设置oDest（vKey）=O源（vKey）
其他的
oDest（vKey）=O源（vKey）
如果结束
如果结束
下一个
设置提取键=oDest
端函数
子输出阵列（oDstRng作为范围，aCells作为变型）
使用oDstRng
.Parent.Select
使用.Resize（1，UBound（aCells）-LBound（aCells）+1）
.NumberFormat=“@”
.Value=aCells
以
以
端接头
子输出2dArray（oDstRng作为范围，aCells作为变体）
使用oDstRng
.Parent.Select
使用。调整大小（_
UBound（aCells，1）-LBound（aCells，1）+1_
UBound（aCells，2）-LBound（aCells，2）+1）
.NumberFormat=“@”
.Value=aCells
以
以
端接头

我的输出如下：

顺便说一句，采用了类似的方法

Sub RBA_Auction_Scrape()

    Dim S_Sheet As Worksheet
    Dim Look_String As String
    Dim Web_HTML As String
    Dim HTTP_OBJ As New MSXML2.XMLHTTP60

    On Error GoTo ERR_LABEL:
    Set S_Sheet = ActiveWorkbook.ActiveSheet
    Web_HTML = ""
    HTTP_OBJ.Open "GET", "https://www.rbauction.com/heavy-equipment auctions", False
    HTTP_OBJ.Send
    On Error Resume Next
    Select Case HTTP_OBJ.Status
        Case 0: Web_HTML = HTTP_OBJ.responseText
        Case 200: Web_HTML = HTTP_OBJ.responseText
        Case Else: GoTo ERR_LABEL
    End Select

    Debug.Print Web_HTML

End Sub