用于在线抓取数据的 VBA 程序使我的笔记本电脑性能变慢

Posted 2023-04-14

【中文标题】用于在线抓取数据的 VBA 程序使我的笔记本电脑性能变慢

【英文标题】：VBA program for scraping data online that makes my laptop performance getting slower

【发布时间】：2016-07-03 16:32:51

【问题描述】：

今天是我第一次创建用于从网站上抓取数据的 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 功能，但我决定用它来知道程序运行了多长时间，因为每次修改它都会变得越来越慢。当我运行上面的程序时，它需要很长时间，所以我停止了它。当我删除了Timer功能后，仍然运行很长时间。我再次停止它，但这一次Sheet1中没有输出。即使在那之后，我的笔记本电脑运行速度非常慢，我将其关闭了两次（非常努力地尝试并花了很长时间才将其关闭）。我试图简化程序，但奇怪的是，虽然它以前可以工作，但它却没有工作。我认为问题出在我的互联网连接上，因为这里正在下雨。我尝试Speed Test 来检查我的互联网连接，但它看起来不错。我测试了五次：

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

那么，问题出在哪里？你能修好它吗？我还想知道如何将表格Forex Rate 中的向上/向下箭头插入A 列中的单元格？我试过Dim Arrow As Icon: Arrow = FOREX.Cells(0).innerHTML，但没有用。

【问题讨论】：

使用 sleep api 并调用 sleep 函数（甚至 250 毫秒）和 DoEvents - 如果您将 IE 文档加载到对象中并仅在内存中的对象，

@dbmitch 抱歉，就像我在 OP 中所说的那样，我是这个新手。我不明白你说的。你能发布你的答案吗？谢谢

【参考方案1】：

这个答案的灵感来自我自己的帖子中的Mr. Jeeped's answer：Code that works once/ twice either by F5 or F8 but then gets multiple errors。我要感谢他为学习 VBA Excel 提供的分步指南。他的慷慨真的帮助了我。

我把它放在工作表代码模块 (Sheet1) 中。它需要工具 ► 参考中的 Microsoft HTML 对象库 和 Microsoft XML, v6.0。该程序的输出几乎与Investing.com 上显示的显示完全相同，包括格式数字（请参阅How to make Excel doesn't truncate 0's in formatting decimal numbers? 上的相关主题）。

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, i.e. 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, i.e. 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