以下代码在过去140天内一直在运行，但5天前它停止了。代码（写得不好＆＃34;浣熊风格＆＃34;）从雅虎财务中删除每日选项表。我有一系列股票符号，一个接一个地送入雅虎。第一个Web请求会启动初始选项页面，该页面将变为htmlfile。我使用getElementsByTagName（＆＃34; select＆＃34;）从htmlfile中提取选项到期日期并创建一个对象。如果object.Item.childNodes.Length＆lt;＆gt; 0则将childnode值加载到一个数组中，然后使用该数组创建URL以提取每月到期选项表。
当我用检查元素（Chrome）打开网页时
Sub HTML_Table_To_Excel()
Dim htm As Object, temp As Variant, r As Long, s As Variant, t As Long, vDate As Variant, d As Long, ldate As Long, web_url As String
Dim obTable As Object, aitemp() As Variant, aiExpDates() As String, lTab As Long, start As Long, sstop As Long, elapsed As Long, z As Long, vwebpage As Object
Dim html_content As Object, lmatch As Long, http As Object, e As Long, hits As Long
Application.ScreenUpdating = False
ReDim aiExpDates(11)
aiExpDates() = Create12ExpirationDates()
start = Timer
hits = 0
temp = [Symbol].Value
'LBound(temp, 1)
For r = LBound(temp, 1) To UBound(temp, 1)
ReDim aitemp(10, 0)
z = 0
d = 0
e = 0
web_url = "http://finance.yahoo.com/quote/" & temp(r, 1) & "/options?p=" & temp(r, 1)
'Create HTMLFile Object
Set html_content = CreateObject("htmlfile")
'Get the WebPage Content to HTMLFile Object
Set http = CreateObject("msxml2.xmlhttp")
With http
.Open "GET", web_url, False
.Send
' While Not .readyState = 4
' Sleep (500)
' Wend
html_content.body.innerHTML = .ResponseText
End With
checkpageload:
hits = hits + 1
On Error Resume Next
Set vwebpage = html_content.getElementsByTagName("select")
If vwebpage.Item.ChildNodes.Length = 0 Then
Set html_content = Nothing
Set http = Nothing
Set html_content = CreateObject("htmlfile")
Set http = CreateObject("msxml2.xmlhttp")
With http
.Open "GET", web_url, False
.Send
' While Not .readyState = 4
' Sleep (500)
' Wend
html_content.body.innerHTML = .ResponseText
End With
d = d + 1
If d = 10 Then
GoTo continue
End If
GoTo checkpageload
End If
hits = hits + 1
ReDim vDate(vwebpage.Item.ChildNodes.Length - 1)
For Each obTable In vwebpage.Item.ChildNodes
lmatch = 0
lmatch = Application.WorksheetFunction.Match(obTable.Value, aiExpDates(), 0)
If lmatch <> 0 Then
vDate(z) = obTable.Value
z = z + 1
End If
Next obTable
ReDim Preserve vDate(z - 1)
z = 0
On Error GoTo 0
For ldate = LBound(vDate) To UBound(vDate)
web_url = "http://finance.yahoo.com/quote/" & temp(r, 1) & "/options?p=" & temp(r, 1) & "&date=" & vDate(ldate)
hits = hits + 1
'Create HTMLFile Object
Set html_content = CreateObject("htmlfile")
Set http = CreateObject("msxml2.xmlhttp")
With http
.Open "GET", web_url, False
.Send
' While Not .readyState = 4
' Sleep (500)
' Wend
html_content.body.innerHTML = .ResponseText
End With
test:
If html_content.getElementsByTagName("tbody").Length < 2 Then
' MsgBox "the page did not load"
Set html_content = Nothing
Set http = Nothing
Set html_content = CreateObject("htmlfile")
Set http = CreateObject("msxml2.xmlhttp")
With http
.Open "GET", web_url, False
.Send
' While Not .readyState = 4 '<---------- wait
' Sleep (500)
' Wend
html_content.body.innerHTML = .ResponseText
End With
d = d + 1
If d = 10 Then
GoTo continue
End If
GoTo test
End If
Set obTable = html_content.getElementsByTagName("tbody")
For s = 0 To obTable(1).Rows.Length - 1
For t = 0 To obTable(1).Rows(0).Cells.Length - 1
aitemp(t, e) = obTable(1).Rows(s).Cells(t).innerText
Next t
aitemp(10, e) = Date - 1
e = e + 1
ReDim Preserve aitemp(UBound(aitemp, 1), UBound(aitemp, 2) + 1)
Next s
If obTable.Length = 3 Then
s = 0: t = 0
For s = 0 To obTable(2).Rows.Length - 1
For t = 0 To obTable(2).Rows(0).Cells.Length - 1
aitemp(t, e) = obTable(2).Rows(s).Cells(t).innerText
Next t
aitemp(10, e) = Date - 1
e = e + 1
ReDim Preserve aitemp(UBound(aitemp, 1), UBound(aitemp, 2) + 1)
Next s
End If
Next ldate
ReDim Preserve aitemp(UBound(aitemp, 1), UBound(aitemp, 2) - 1)
Worksheets(temp(r, 1)).Activate
ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Selection.Resize(UBound(aitemp, 2), UBound(aitemp, 1) + 1).Value = Application.Transpose(aitemp)
ActiveSheet.UsedRange.Columns.AutoFit
continue:
Next r
ThisWorkbook.Save
sstop = Timer
elapsed = (sstop - start) / 60
MsgBox elapsed & vbCr & " # of Resubmittals " & d & vbCr & "webhits = " & hits
End Sub