Raspagem de dados do sítio web que utiliza o vba

Momento Wiki:

XHR é uma API na forma de um objecto cujos métodos transferem dados entre um navegador web e um servidor web. O objecto é fornecido pela JavaScript do navegador ambiente

No código abaixo, a tabela é agarrada pelo seu id cr1.

No sub auxiliar, WriteTable, fazemos um loop nas colunas (td} e depois nas linhas da tabela (tr}), e finalmente atravessamos o comprimento de cada linha da tabela, célula da tabela por celula. Como só queremos dados das colunas 1 e 8, é usada uma declaração Select Case especifique o que está escrito na folha.

Mostrar a vista da página web:

Saída do Código Da Amostra:

VBA:

Option Explicit
Public Sub GetRates()
    Dim sResponse As String, html As New HTMLDocument '<== Tools > References > HTML Object Library
    Dim hTable As HTMLTable
    Application.ScreenUpdating = False
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://uk.investing.com/rates-bonds/financial-futures", False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" 
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
    With html
        .body.innerHTML = sResponse
        Set hTable = .getElementById("cr1")
        WriteTable hTable, 1, ThisWorkbook.Worksheets("Sheet1")
    End With
    Application.ScreenUpdating = True
End Sub

Public Sub WriteTable(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
    Dim tSection As Object, tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, C As Long, tBody As Object
    r = startRow: If ws Is Nothing Then Set ws = ActiveSheet
    With ws
        Dim headers As Object, header As Object, columnCounter As Long
        Set headers = hTable.getElementsByTagName("th")
        For Each header In headers
            columnCounter = columnCounter + 1
            Select Case columnCounter
            Case 2
                .Cells(startRow, 1) = header.innerText
            Case 8
                .Cells(startRow, 2) = header.innerText
            End Select
        Next header
        startRow = startRow + 1
        Set tBody = hTable.getElementsByTagName("tbody")
        For Each tSection In tBody
            Set tRow = tSection.getElementsByTagName("tr")
            For Each tr In tRow
                r = r + 1
                Set tCell = tr.getElementsByTagName("td")
                C = 1
                For Each td In tCell
                    Select Case C
                    Case 2
                        .Cells(r, 1).Value = td.innerText
                    Case 8
                        .Cells(r, 2).Value = td.innerText
                    End Select
                    C = C + 1
                Next td
            Next tr
        Next tSection
    End With
End Sub

Você pode usar o objecto winhttprequest em vez do internet explorer, pois é bom carregar dados excluindo Imagens n anúncio em vez de descarregar a página web completa, incluindo imagens de anúncio n que tornam o objecto do internet explorer pesado em comparação com o objecto do winhttpRequest.

Sub ExtractLastValue()

Set objIE = CreateObject("InternetExplorer.Application")

objIE.Top = 0
objIE.Left = 0
objIE.Width = 800
objIE.Height = 600

objIE.Visible = True

objIE.Navigate ("https://uk.investing.com/rates-bonds/financial-futures/")

Do
DoEvents
Loop Until objIE.readystate = 4

MsgBox objIE.document.getElementsByClassName("pid-8907-last")(0).innerText

End Sub

E se você é novo para raspar web por favor leia este post no blog.

Raspagem Da Web-Noções Básicas

E também existem várias técnicas para extrair dados de páginas web. Este artigo explica alguns deles com exemplos.

Raspagem da Web-recolha de dados de uma página web

Sub get_data_web()

Dim appIE As Object
Set appIE = CreateObject("internetexplorer.application")

With appIE
    .navigate "https://finance.yahoo.com/quote/NQ%3DF/futures?p=NQ%3DF"
    .Visible = True
End With

Do While appIE.Busy
    DoEvents
Loop

Set allRowofData = appIE.document.getElementsByClassName("Ta(end) BdT Bdc($c-fuji-grey-c) H(36px)")

Dim i As Long
Dim myValue As String

Count = 1

    For Each itm In allRowofData

        For i = 0 To 4

        myValue = itm.Cells(i).innerText
        ActiveSheet.Cells(Count, i + 1).Value = myValue

        Next

        Count = Count + 1

    Next

appIE.Quit
Set appIE = Nothing


End Sub