我有一个工作正常的代码,但在下面代码的注释行中触发错误“下标超出范围”。
我在线使用了json格式化程序查看了XML结构,我似乎没有看到触发错误的原因。现在,如果我注释掉最后两个节点,代码就可以正常工作。我使用的代码可以引用这里 - Extracting HTML elements values using their classes
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.betfair.com/www/sports/exchange/readonly/v1/bymarket?_ak=nzIFcwyWhrlwYMrh&alt=json¤cyCode=USD&locale=en&marketIds=1.161189078,1.161073119,1.161362337,1.161362195,1.161362198,1.161362200,1.161362186,1.161362202,1.161362187,1.161362205,1.161362188,1.161362189,1.161425408&rollupLimit=25&rollupModel=STAKE&types=MARKET_STATE,%20EVENT,RUNNER_DESCRIPTION,RUNNER_STATE,RUNNER_EXCHANGE_PRICES_BEST", False
.send
s = .responseText
Set json = JsonConverter.ParseJson(s)
End With
Dim runners As Object, runner As Object, results(), r As Variant
Set runners = json("eventTypes")(1)("eventNodes")
ReDim results(1 To runners.Count, 1 To 7)
For Each runner In runners
r = r + 1
results(r, 1) = runner("event")("eventName")
results(r, 2) = runner("marketNodes")(1)("runners")(1)("exchange")("availableToBack")(1)("price")
results(r, 3) = runner("marketNodes")(1)("runners")(1)("exchange")("availableToLay")(1)("price")
results(r, 4) = runner("marketNodes")(1)("runners")(2)("exchange")("availableToBack")(1)("price")
results(r, 5) = runner("marketNodes")(1)("runners")(2)("exchange")("availableToLay")(1)("price")
''results(r, 6) = runner("marketNodes")(1)("runners")(3)("exchange")("availableToBack")(1)("price")
''results(r, 7) = runner("marketNodes")(1)("runners")(3)("exchange")("availableToLay")(1)("price")
Next
我需要帮助来修复该错误并使所有节点正常工作。
最佳答案
您的错误来自尝试访问 runners
中超出范围(太高)的索引收藏。当您到达索引 11(根据 VBA JSON 集合,基于 0 - 或基于 1 时为 12)时,runners
中只有两个项目,而不是 3。收藏。我通常用 On Error Resume Next On Error GoTo 0
处理这个问题。围绕填充数组的行进行包装 - 这会为丢失的项目留下空白。到目前为止,当您知道要填充的数组的尺寸并且只需要处理一些不存在的项目时,我的偏好是。
VBA:
Option Explicit
Public Sub WriteOutResults()
Dim s As String, json As Object
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.betfair.com/www/sports/exchange/readonly/v1/bymarket?_ak=nzIFcwyWhrlwYMrh&alt=json¤cyCode=USD&locale=en&marketIds=1.161189078,1.161073119,1.161362337,1.161362195,1.161362198,1.161362200,1.161362186,1.161362202,1.161362187,1.161362205,1.161362188,1.161362189,1.161425408&rollupLimit=25&rollupModel=STAKE&types=MARKET_STATE,%20EVENT,RUNNER_DESCRIPTION,RUNNER_STATE,RUNNER_EXCHANGE_PRICES_BEST", False
.send
s = .responseText
Set json = JsonConverter.ParseJson(s)
End With
Dim runners As Object, runner As Object, results(), r As Variant
Set runners = json("eventTypes")(1)("eventNodes")
ReDim results(1 To runners.Count, 1 To 7)
For Each runner In runners
r = r + 1
On Error Resume Next
results(r, 1) = runner("event")("eventName")
results(r, 2) = runner("marketNodes")(1)("runners")(1)("exchange")("availableToBack")(1)("price")
results(r, 3) = runner("marketNodes")(1)("runners")(1)("exchange")("availableToLay")(1)("price")
results(r, 4) = runner("marketNodes")(1)("runners")(2)("exchange")("availableToBack")(1)("price")
results(r, 5) = runner("marketNodes")(1)("runners")(2)("exchange")("availableToLay")(1)("price")
results(r, 6) = runner("marketNodes")(1)("runners")(3)("exchange")("availableToBack")(1)("price")
results(r, 7) = runner("marketNodes")(1)("runners")(3)("exchange")("availableToLay")(1)("price")
On Error GoTo 0
Next
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
关于json - 如何修复 XML HTTP 请求中的 "Subscript out of range"错误,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/57535199/