用于在线抓取数据的VBA程序，这会使我的笔记本电脑性能变慢 [英] VBA program for scraping data online that makes my laptop performance getting slower

问题描述

今天是我第一次创建VBA Excel程序来从网站抓取数据.首先，我尝试了一个简单的程序来抓取单个值并将其打印在cells(1,1)中.尽管多次失败并从我的防病毒软件收到许多警告，但我终于成功了.然后，我将该程序修改为一个复杂的程序，并在每次修改时都运行该程序，以检查是否发生了错误.然后我意识到的一件事是，修改后每次运行程序时，笔记本电脑的运行速度都很慢，处理器风扇的运行速度太快，而且声音很大.但是我的程序仍然有效.这是我的完整代码:

Today is the first time ever I create a VBA Excel program for scraping data from a website. First, I tried with a simple program for scraping a single value and print it in cells(1,1). Though failed many times and got many warnings from my antivirus, I finally succeed. Then I modified the program into a complicated one and I run the program every modification to check whether the error occurred or not. One thing I then realized is every times I run the program after modification, my laptop is running very slow and its processor fan is running too fast and is extremely loud. Yet my program still worked. Here is my full code:

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函数，但是我决定使用它来了解程序运行了多长时间，因为每次修改的速度都越来越慢.当我在上面运行该程序时，花了很长时间，所以我停止了它.当我删除计时器功能时，仍会运行很长时间.我再次停止了它，但是这次在Sheet1中没有输出.即使在那之后，我的笔记本电脑仍然运行非常缓慢，我将其关闭两次(非常尝试，并且花了很长时间才将其关闭).我试图简化该程序，但奇怪的是，尽管它以前曾奏效，但却没有奏效.我以为问题是我的互联网连接，因为这里正在下雨.我尝试了速度测试来检查我的互联网连接，但看起来还不错.进行五次测试:

I didn't use Timer function before, but I decided to use it to know how long the program running because it's getting slower and slower every modification. When I run the program above, it took time very long so I stopped it. When I deleted the Timer function, still run very long. I stopped it again, but this time there was no output in Sheet1. Even after that, my laptop works very slow and I shut it down twice (tried it very hard and took ages to turn it off). I tried to simplify the program, but strangely it didn't work though it worked before. I thought the problem is my internet connection since it's raining here. I tried Speed Test to check my internet connection, but it looked fine. Test it five times I got:

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，但是没有用.

So, where is the problem? Can you fix it? I also want to know how to insert the arrow up/ down in the table Forex Rate to cells in Column A? I tried Dim Arrow As Icon: Arrow = FOREX.Cells(0).innerHTML, but didn't work.

推荐答案

此答案的灵感来自 先生.吉普(Jeeped)的回答 在我自己的帖子上:该代码在F5或F8上可以一次/两次起作用，但随后会多次错误.我要感谢他为学习VBA Excel的分步指南.他的慷慨确实帮助了我.

This answer is inspired by Mr. Jeeped's answer on my own post: Code that works once/ twice either by F5 or F8 but then gets multiple errors. I would like to thank him for a step-by-step guide to learning VBA Excel. His generosity really helped me.

我将其放在工作表代码模块(Sheet1)中.它需要工具►引用中的 Microsoft HTML对象库和 Microsoft XML v6.0 .该程序的输出与 Investing.com 包括格式数字(请参见如何使Excel在格式化十进制数字时不会截断0的相关主题?).

I put this in a worksheet code module (Sheet1). It requires Microsoft HTML Object Library and Microsoft XML, v6.0 in Tools ► References. The output of the program is almost exactly the same display as shown on Investing.com included the format numbers (see the related topic on 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

这篇关于用于在线抓取数据的VBA程序，这会使我的笔记本电脑性能变慢的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！