VBA program for scraping data online that makes my laptop performance getting slower

Question

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

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

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.

Answer 1

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.

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