vba - 为什么我在 VBA 中的 HTML 网站搜索不断返回相同的数据集而不是更新？

Question

我正在使用此代码从 ASX 网站提取期权价格。数据被传输到一个数组并复制到 excel 中。然后一个单独的子去除隐含波动率估计。

http://www.asx.com.au/asx/markets/optionPrices.do?by=underlyingCode&underlyingCode=xjo&expiryDate=&optionType=B

问题是 sub 仅在第一次运行时才能正常工作。随后运行时，子程序返回之前的数据集，而不是在网站上捕获新数据。

我在代码中包含了一个测试 debug.print 行来演示这个问题:

对于 7 月 21 日的 5150 调用 (XJOEW7)，表对象返回 148 的出价和 153 的出价(第 110 行，第 5 和 6 列)——与当天早些时候运行子时完全相同。 ASX 网页上的正确价格为 178.30(与市场收盘时相同的买入/卖出价)。

为什么表格对象没有捕获网页上的新数据，而是返回较早的值？

Sub Data()

Application.ScreenUpdating = False

Dim xml As Object
Dim html As Object
Dim objTable As Object
Dim result As String
Dim lRow As Long
Dim lngTable As Long


'DATA SEARCH

Set xml = CreateObject("MSXML2.XMLHTTP.6.0")

With xml
    .Open "GET", "http://www.asx.com.au/asx/markets/optionPrices.do?by=underlyingCode&underlyingCode=xjo&expiryDate=&optionType=B", False
    .send
End With

While xml.readyState <> 4
    DoEvents
Wend

result = xml.responseText
Set html = CreateObject("htmlfile")
html.body.innerHTML = result
Set objTable = html.getElementsByTagName("table")


Dim A() As Variant 'Output array
Dim i As Integer 'Row loop
Dim j As Integer 'Column loop


'TRANSFER DATA TO EXCEL

ReDim A(objTable(0).Rows.Length, objTable(0).Rows(1).Cells.Length) 'Resize output array

For lngTable = 0 To objTable.Length - 1

    For i = 0 To UBound(A, 1) - 1 'Row loop

        For j = 0 To UBound(A, 2) - 1 'Column loop

            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'TEST CODE TO DEMONSTRATE PROBLEM

            If i = 110 Then

            Debug.Print objTable(lngTable).Rows(i).Cells(j).InnerText

            End If

            'END TEST CODE
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

            A(i, j) = objTable(lngTable).Rows(i).Cells(j).InnerText

        Next j

    Next i

Next lngTable

With Worksheets("Data").Range("A1").Resize(UBound(A, 1), UBound(A, 2)) 'Copy output array to excel

    .Name = "RawPrices"
    .Value = A
    .ClearFormats

End With


With Worksheets("Data").Range("RawPrices").Columns(2) 'Format dates

    .TextToColumns Destination:=Worksheets("Data").Range("RawPrices").Columns(2).Rows(1), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 4), TrailingMinusNumbers:=True

End With

Application.ScreenUpdating = True

Call BlackScholes 'Call Newtown Raphson

End Sub

Answer 1

因为您每次都调用相同的 URL，所以很有可能您正在检索页面的缓存版本，而不是访问服务器以获取最新数据。

人们使用WinHTTP解决 XmlHttp 和缓存的已知问题。

下面是使用这种替代方法检索 HTML 的示例代码。您可以将此功能插入问题中发布的代码中。

Option Explicit

Sub Test()

    Dim strUrl As String
    Dim strHtml As String

    strUrl = "http://www.asx.com.au/asx/markets/optionPrices.do?by=underlyingCode&underlyingCode=xjo&expiryDate=&optionType=B"
    strHtml = GetHtmlString(strUrl)

    Debug.Print strHtml

End Sub

Function GetHtmlString(strUrl As String) As String

    Dim objRequest As Object
    Dim strHtml As String

    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    With objRequest
        'synchronous call
        .Open "GET", strUrl, False
        .Send
    End With

    GetHtmlString = objRequest.ResponseText

End Function