VBA程序在网上抓取数据，使我的笔记本电脑性能变慢
今天是我第一次创build一个VBA Excel程序来从网站上抓取数据。 首先，我尝试了一个简单的程序来刮取单个值并将其打印在cells(1,1) 。 虽然多次失败，并从我的杀毒软件得到很多警告，但我终于成功了。 然后我把程序修改成一个复杂的程序，每修改一次运行程序来检查错误是否发生。 然后我意识到的一件事情是每次修改后运行程序，我的笔记本电脑运行速度非常慢，处理器风扇运行速度太快，非常响亮。 然而我的程序仍然有效。 这是我的完整代码：
Sub Download_Data() Dim IE As Object, Data_FOREX As String T0 = Timer Application.ScreenUpdating = False Range("A:J").Clear Set IE = CreateObject("internetexplorer.application") With IE .navigate "http://uk.investing.com/currencies/streaming-forex-rates-majors" .Visible = False End With Do DoEvents Loop Until IE.readyState = READYSTATE_COMPLETE For i = 1 To 13 Set FOREX = IE.document.getElementById("pair_" & i) For j = 1 To 9 Data_FOREX = FOREX.Cells(j).innerHTML If j = 1 Then Cells(i + 1, j + 1) = Mid(Data_FOREX, 11, 7) Else Cells(i + 1, j + 1) = Data_FOREX End If If Cells(i + 1, 8) < 0 Then Cells(i + 1, 8).Font.Color = vbRed Cells(i + 1, 9).Font.Color = vbRed Else Cells(i + 1, 8).Font.Color = vbGreen Cells(i + 1, 9).Font.Color = vbGreen End If If j = 9 Then Cells(i + 1, 10) = Mid(Data_FOREX, 4, 2) & "/" & Mid(Data_FOREX, 1, 2) End If Next j Next i IE.Quit Set IE = Nothing Cells(1, 2) = "Pair" Cells(1, 3) = "Bid" Cells(1, 4) = "Ask" Cells(1, 5) = "Open" Cells(1, 6) = "High" Cells(1, 7) = "Low" Cells(1, 8) = "Change" Cells(1, 9) = "% Change" Cells(1, 10) = "Date" Range("A1:J").Font.Bold = True Range("A1:J1").HorizontalAlignment = xlCenter Range("C:H").NumberFormat = "0.0000" Columns("A:J").AutoFit MsgBox "Downloading data is complete." _ & vbNewLine & "The running time is " & Round(Timer - T0, 2) & " s." End Sub
我之前没有使用Timer函数，但是我决定使用它来知道程序运行多长时间，因为每次修改都会变得越来越慢。 当我运行上面的程序，花了很长时间，所以我停下来了。 当我删除了定时器function，仍然运行很长时间。 我再次停下来，但是这次Sheet1没有输出。 即使在那之后，我的笔记本电脑的工作非常缓慢，我关了两次（非常努力，花了很长时间才把它关掉）。 我试图简化程序，但奇怪的是，虽然它以前工作，它没有工作。 我以为这个问题是因为在这里下雨，所以我的互联网连接。 我试过速度testing来检查我的networking连接，但看起来不错。 testing五次我得到：
Ping (ms) Download Speed (Mbps) Upload Speed (Mbps) 10 3.64 0.62 10 3.24 0.34 11 2.94 0.53 11 3.33 0.58 10 4.84 0.49
那么，问题在哪里？ 你能修好它吗？ 我也想知道如何在列A中的单元格中将表格向上/向下插入箭头？ 我试图Dim Arrow As Icon: Arrow = FOREX.Cells(0).innerHTML ，但没有奏效。
这个答案是由Jeeped先生在我自己的post上的答案所启发的： 代码可以通过F5或F8一次或两次工作，但是会出现多个错误 。 我想感谢他一步一步地学习VBA Excel。 他的慷慨帮助我。
我把它放在工作表代码模块（Sheet1）中。 它需要工具►参考中的Microsoft HTML Object Library和Microsoft XML v6.0 。 该程序的输出几乎是完全相同的显示，如Investing.com上显示的格式数字（请参阅有关如何使Excel不会截断格式化十进制0中的0的相关主题）。
Sub Download_Data() Dim FOREX As New HTMLDocument, xmlHTTP As New MSXML2.XMLHTTP60 Dim Website_URL As String, Data_FOREX As String, Range_Data As Range Dim i As Long, j As Long, Dec_Number As Long, Last_Row As Long Application.ScreenUpdating = False Range("A:J").Clear Website_URL = "http://uk.investing.com/currencies/streaming-forex-rates-majors" With xmlHTTP .Open "GET", Website_URL, False .setRequestHeader "User-Agent", "XMLHTTP/1.0" .send If .Status <> 200 Then GoTo Safe_Exit FOREX.body.innerHTML = .responseText End With For i = 1 To 20 For j = 1 To 9 With FOREX If Not .getElementById("pair_" & i) Is Nothing Then With .getElementById("pair_" & i) Data_FOREX = CStr(.Cells(j).innerText) Cells(i + 1, j + 1).Value = Data_FOREX 'Formatting the numbers, ie quote prices If j > 1 And j < 7 Then Dec_Number = Len(Data_FOREX) - InStr(Data_FOREX, ".") Cells(i + 1, j + 1) = Val(Data_FOREX) If Dec_Number = Len(Data_FOREX) Then Cells(i + 1, j + 1).NumberFormat = "0" Else Cells(i + 1, j + 1).NumberFormat = "0." _ & WorksheetFunction.Rept("0", Dec_Number) End If End If End With Else Exit For End If End With Next j 'Copy number format in column G and paste it in column H Cells(i + 1, "G").Copy Cells(i + 1, "H").PasteSpecial Paste:=xlPasteFormats 'Coloring specific data If Cells(i + 1, "H") < 0 Then Cells(i + 1, "H").Font.Color = vbRed Cells(i + 1, "I").Font.Color = vbRed Else Cells(i + 1, "H").Font.Color = RGB(0, 150, 0) Cells(i + 1, "I").Font.Color = RGB(0, 150, 0) End If Cells(i + 1, "B").Font.Bold = True Cells(i + 1, "B").Font.Color = RGB(18, 86, 168) Range(Cells(i + 1, "H"), Cells(i + 1, "I")).Font.Bold = True Next i 'Deleting the cells with empty entries, ie pair_i doesn't exist Last_Row = Cells(Rows.Count, "B").End(xlUp).Row Set Range_Data = Range("A2:J" & Last_Row).SpecialCells(xlCellTypeBlanks) Range_Data.Rows.Delete Shift:=xlShiftUp 'Format table header Cells(1, 2) = "Pair" Cells(1, 3) = "Bid" Cells(1, 4) = "Ask" Cells(1, 5) = "Open" Cells(1, 6) = "High" Cells(1, 7) = "Low" Cells(1, 8) = "Change" Cells(1, 9) = "% Change" Cells(1, 10) = "Time" Range("A1:J1").Font.Bold = True Range("A1:J1").HorizontalAlignment = xlCenter Range("A:J").VerticalAlignment = xlCenter Columns("A:J").ColumnWidth = 10 Safe_Exit: Set FOREX = Nothing: Set xmlHTTP = Nothing End Sub