Question

提前感谢您的帮助。

当我通过代码运行代码时，它会停止。这是拉动共同基金数据，所以如果你想自己测试代码......我会使用（INDZX，CULAX，ABRZX，TAGBX，PRPFX（不要使用这些共同基金，它们不好;只是为了一个例子）））。我真的不得不坐在我的电脑旁边擦掉数据已被拉过来的代码，以便它可以重新开始;非常耗时。

请你们中的一个人帮助我。

如果您对此有任何疑问，请与我们联系。

只是在它完全断开时添加，并查看调试，它突出显示“Do While IE.readystate＆lt;＆gt; 4：DoEvents：Loop

我遇到的另一个问题是，当没有剩余代码时，代码会继续运行。

Sub upDown()

Dim IE As Object, Doc As Object, lastRow As Long, tblTR As Object, tblTD As Object,  
strCode As String
lastRow = Range("H65000").End(xlUp).Row


Set IE = CreateObject("internetexplorer.application")
IE.Visible = True


last_row = Sheets("Tickers").Range("H1").End(xlDown).Row

ini_row_dest = 1

Sheets("upDown").Select

Sheets("upDown").Range("A1:m10000").ClearContents

Application.ScreenUpdating = True






     For i = 1 To lastRow
    Application.StatusBar = "Updating upDown" & i & "/" & last_row

    row_dest = ini_row_dest + (i - 1)

    strCode = "Tickers"    ' Range("A" & i).value  
    list_symbol = Sheets("Tickers").Range("h" & i)
    IE.navigate "http://performance.morningstar.com/fund/ratings-risk.action?t=" & list_symbol

    Do While IE.readystate <> 4: DoEvents: Loop

    Set Doc = CreateObject("htmlfile")
    Set Doc = IE.document

    tryAgain:

    Set tblTR = Doc.getelementbyid("div_upDownsidecapture").getelementsbytagname("tr")(3)

    If tblTR Is Nothing Then GoTo tryAgain
    On Error Resume Next



    j = 2
    For Each tblTD In tblTR.getelementsbytagname("td")
        tdVal = Split(tblTD.innerText, vbCrLf)
        Cells(i, j) = tdVal(0)
        Cells(i, j + 1) = tdVal(1)
        j = j + 2



     Next

    Sheets("upDown").Range("A" & row_dest).Value = list_symbol
     Next i

    Range("A3").Select

    Application.StatusBar = False

    Application.Calculation = xlAutomatic


    End Sub

Answer 1

根据你的描述，当它“卡住”时你按CTRL-Break，然后停在

 Do While IE.readystate<> 4: DoEvents: Loop

这意味着IE正忙。你可能应该找出原因。如果切换到IE窗口会发生什么？也许它有一个弹出窗口？ morningstar.com 完全有可能检测到您正在抓取数据并且正在暂停数据。通常，您需要支付某种订阅才能获得此类内容。

无论如何，你可以做的是放入一个检测到这种状态并尝试恢复的“看门狗”。下面是一些代码，但它基本上是一个黑客，我不太明白你的行索引是如何工作的。下面的代码使用Goto，这只是一种懒惰的做事方式，但它肯定不比现有代码差。

无论如何试试看。您可能会发现IE.Quit行可能会提示您关闭IE，但至少它可以从失败的位置重新启动，您无需清除代码并重新开始。

另一种解决方案可能是保存半完成的工作簿，并根据哪些代码具有数据而哪些代码没有

来更改代码以从中断处继续获取

Sub upDown()

Dim IE As Object, Doc As Object, lastRow As Long, tblTR As Object, tblTD As Object,  
strCode As String
Dim iWatchDog as Integer
iWatchDog = 1

lastRow = Range("H65000").End(xlUp).Row
ini_row_dest = 1
Sheets("upDown").Select
Sheets("upDown").Range("A1:m10000").ClearContents

Start:
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True

last_row = Sheets("Tickers").Range("H1").End(xlDown).Row


Application.ScreenUpdating = True






For i = 1 To lastRow
Application.StatusBar = "Updating upDown" & i & "/" & last_row

row_dest = ini_row_dest + (i - 1)

strCode = "Tickers"    ' Range("A" & i).value  
list_symbol = Sheets("Tickers").Range("h" & i)
IE.navigate "http://performance.morningstar.com/fund/ratings-risk.action?t=" &     list_symbol

Do While IE.readystate <> 4
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    iWatchDog = iWatchDog + 1
    If iWatchDog >= 10000 Then 
        Application.StatusBar = "Stuck - resetting"
        iWatchDog = 1
        IE.Stop
        IE.Quit
        Set IE = Nothing
        DoEvents
        DoEvents
        DoEvents
        DoEvents
        Goto Start
    End If
Loop


Set Doc = CreateObject("htmlfile")
Set Doc = IE.document

tryAgain:

Set tblTR = Doc.getelementbyid("div_upDownsidecapture").getelementsbytagname("tr")(3)

If tblTR Is Nothing Then GoTo tryAgain
On Error Resume Next



j = 2
For Each tblTD In tblTR.getelementsbytagname("td")
    tdVal = Split(tblTD.innerText, vbCrLf)
    Cells(i, j) = tdVal(0)
    Cells(i, j + 1) = tdVal(1)
    j = j + 2
Next

Sheets("upDown").Range("A" & row_dest).Value = list_symbol
 Next i

Range("A3").Select

Application.StatusBar = False

Application.Calculation = xlAutomatic


End Sub

这3,800行股票数据最终会走向何方？进入数据库还是送入另一张Excel表格？

VBA代码有时会工作，其他时候会中断。我错过了本规范中的内容吗？

1 个答案: