我建立了一个宏,用于循环遍历股票行情机和一列,并使用网络查询从雅虎财经中提取这些股票行情机的数据
它运行 10、15、20 个 Web 查询时都运行良好,但在前 20 或 30 个 Web 查询的某个时刻,它就会崩溃
我首先要说的是,我是 VBA 代码的极端业余爱好者,但我尝试了一些方法来解决这个问题(清除缓存、使用暂停),但似乎都没有效果。
它不会每次都在同一项上失败,但状态栏中总是显示“正在连接到网络”文本,所以我觉得它与连接超时有关,但目前我还不确定如何解决它。欢迎任何想法,以及我可能遗漏的任何代码优化。谢谢!
Sub GetData()
Application.Calculation = xlManual
' make the website a variable
Dim sURL As String
Dim Ticker As String
Dim iRow As Integer
Dim iCol As Integer
Dim wqError As ErrObject
' create web query if it doesn't exist
If Worksheets("query").QueryTables.Count = 0 Then
With Worksheets("query").QueryTables.Add(Connection:="URL;", Destination:=Range("Query!A1"))
.Name = "market_data.asp"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "4"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
End With
End If
iRow = 2
iCol = 2
'Loop through Tickers
Do While Worksheets("Data").Range("A" & iRow).Value <> ""
Ticker = Worksheets("Data").Range("A" & iRow).Value
sURL = "http://finance.yahoo.com/q?s=" & Ticker
With Worksheets("query")
.Cells.Clear
.QueryTables(1).Connection = "URL;" & sURL
On Error Resume Next
.QueryTables(1).Refresh BackgroundQuery:=False
Set wqError = Err
On Error GoTo 0
If wqError.Number = 0 Then 'No error
.Range("B1").Copy Worksheets("Data").Cells(iRow, iCol)
.Range("B5").Copy Worksheets("Data").Cells(iRow, iCol + 1)
.Range("B13:B14").Copy Worksheets("Data").Cells(iRow, iCol + 2)
.Range("B18").Copy Worksheets("Data").Cells(iRow, iCol + 4)
.Range("B15").Copy Worksheets("Data").Cells(iRow, iCol + 5)
.Range("B22").Copy Worksheets("Data").Cells(iRow, iCol + 6)
.Range("B16").Copy Worksheets("Data").Cells(iRow, iCol + 7)
.Range("B20").Copy Worksheets("Data").Cells(iRow, iCol + 8)
.Range("B19").Copy Worksheets("Data").Cells(iRow, iCol + 9)
.Range("B25").Copy Worksheets("Data").Cells(iRow, iCol + 10)
.Range("B24").Copy Worksheets("Data").Cells(iRow, iCol + 11)
ElseIf wqError.Number <> 1004 Then
'Report error because it isn't the expected error 1004 Web query returned no data
MsgBox "Web query refresh for " & String(2, vbCrLf) & sURL & String(2, vbCrLf) & " returned error number " & wqError.Number & String(2, vbCrLf) & wqError.Description
End If
End With
iRow = iRow + 1
If iRow Mod 5 = 0 Then Delete_IE_Cache
If iRow Mod 20 = 0 Then ActiveWorkbook.Save
If iRow Mod 20 = 0 Then Application.Wait (Now + TimeValue("0:00:03"))
Loop
'Format results
With Sheets("data")
Range("A:M").HorizontalAlignment = xlCenter
Range("A:A").NumberFormat = "Text"
Range("D:D").NumberFormat = "Text"
Range("I:I").NumberFormat = "Text"
Range("B:C").NumberFormat = "0.00"
Range("E:H").NumberFormat = "0.00"
Range("K:M").NumberFormat = "0.00"
End With
Application.Calculation = xlCalculationAutomatic
End Sub
答案1
我没有看到任何等待页面加载完成的代码...这可能不是必需的,但将其放在模块顶部然后在导航到网站+股票行情机后调用它并不会有什么坏处。
Private Declare Sub AppSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Public Sub PauseApp(PauseInSeconds As Long)
Call AppSleep(PauseInSeconds)
End Sub
然后在你的代码中,
sURL = "http://finance.yahoo.com/q?s=" & Ticker
Call sleepie(sURL)
正如我说的,它可能根本无法解决您的问题,但它肯定会有所帮助。