как извлечь данные с сайта в vba?

Question

Я пытаюсь извлечь определенные данные с сайта и вставить на лист, чтобы ежедневно обновлять базу данных. Но так как невозможно загрузить таблицу в формате Excel или CSV, я должен извлечь таблицу непосредственно с сайта.

следуйте моему коду и где я с проблемой (где "ЗДЕСЬ").

Sub Scrape_Stats()

    'Create Internet Explorer Browser
    Dim appIE As Object
    Set appIE = CreateObject("internetexplorer.application")

    'Ask Browser to navigate to website (.Visible=False will hide IE when running)
    With appIE
        .Navigate "https://www.infomoney.com.br/mercados/ferramentas/contratos-di-futuro"
        .Visible = True
    End With

    'Have the macro pause while IE is busy opening and navigating
    Do While appIE.Busy
        DoEvents
    Loop

    'Designate the table to be extracted and Copy the data from table - HERE



    'Close IE and clear memory
    appIE.Quit
    Set appIE = Nothing

    'Clear area and paste extracted text into the appropriate sheet/cells - HERE
    Worksheets("Sheet1").Range("A2:H1000").ClearContents
    Sheets("PPG").Select
    Range("A2").Select

End Sub

Answer 1

Гораздо быстрее выдать запрос xmlhtttp без открытия браузера и анализа json, скрытого в одном из атрибутов (data-DIContracts) ответа.

Я использую jsonconverter.bas, который вы можете загрузить с здесь . Как только вы добавите .bas в свой проект, перейдите в vbe> tools> reference и добавьте ссылку на Microsoft Scripting Runtime, а одну для Microsoft HTML Object Library.

.

Линия

.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"

защищает от кеширования результатов при частых обновлениях страниц.

Option Explicit
Public Sub GetTable()
    Dim sResponse As String, html As HTMLDocument, json As Object, i As Long
    Application.ScreenUpdating = False
    Set html = New HTMLDocument
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.infomoney.com.br/mercados/ferramentas/contratos-di-futuro", False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    With html
        .body.innerHTML = sResponse
        Set json = JsonConverter.ParseJson(.querySelector("#serverDI").getAttribute("data-DIContracts"))
    End With 
    With ThisWorkbook.Worksheets("Sheet1")
        .Cells.ClearContents
        .Cells(1, 1).Resize(1, UBound(json(1).keys) + 1) = json(1).keys
        For i = 1 To json.Count
            .Cells(i + 1, 1).Resize(1, UBound(json(i).keys) + 1) = json(i).Items
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

Существует другой подход, который вы можете попробовать.Я использовал селекторы в скрипте, чтобы избавиться от многословия.

Sub FetchTabularContent()
    Dim IE As New InternetExplorer, Html As HTMLDocument
    Dim I&, C&, N&, R&

    With IE
        .Visible = False
        .navigate "https://www.infomoney.com.br/mercados/ferramentas/contratos-di-futuro"
        While .Busy = True Or .readyState < 4: DoEvents: Wend
        Set Html = .document

        With Html.querySelectorAll("table tr")
            For N = 1 To .Length - 1
                With .item(N).querySelectorAll("th,td")
                    For I = 0 To .Length - 1
                        C = C + 1: ThisWorkbook.Worksheets("Sheet1").Cells(R + 1, C) = .item(I).innerText
                    Next I
                    C = 0: R = R + 1
                End With
            Next N
        End With
    End With
End Sub

Ссылка для добавления перед выполнением:

Microsoft Internet Controls
Microsoft HTML Object Library

Answer 3

Что-то вроде должно работать, я использую буфер обмена, чтобы переместить данные в таблице за один раз.

Sub Scrape_Stats()
    Dim Clip As Object: Set Clip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Dim Text As String
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")

    With CreateObject("internetexplorer.application")
        .Navigate "https://www.infomoney.com.br/mercados/ferramentas/contratos-di-futuro"
         Do While .Busy And .readyState <> 4: DoEvents: Loop
         Text = .Document.getElementsByTagName("Table")(1).outerhtml
        .Quit
    End With

    Clip.SetText Text
    Clip.PutInClipboard

    ws.Range("A2:H1000").ClearContents
    ws.Range("A2").Select
    ws.PasteSpecial Format:="Unicode Text"
    Set Clip = Nothing
End Sub