为什么我的HTML网站searchVBA保持返回相同的数据集,而不是更新?

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

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

问题是,只有在第一次运行时,sub才能正常工作。 随后运行时,该子将返回以前的数据集,而不是在网站上捕获新数据。

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

这个表格对象返回了一个148的出价,以及5150的7月21日电话(XJOEW7)的报价153(第110行,第5列和第6列) – 与当天早些时候运行的时候完全相同。 ASX网页上的正确价格是178.30(与市场closures相同的出价/报价)。

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

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 

由于您每次都调用相同的URL,所以很有可能您正在检索caching版本的页面,而不是为最新数据提供服务器。

人们使用WinHTTP来解决XmlHttp和caching中已知的问题。

以下是使用这种替代方法检索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