Соскоб в Интернете на Investing.com с Excel vba

Question

Я не знаю vba.Используется только макро рекордер.Мне нужно загрузить данные с веб-страницы в электронную таблицу Excel, и с моим знанием vba я не способен.

В частности, что я хочу сделать макрос, чтобы загрузить в Excel таблицу данных изстраница: https://www.investing.com/equities/cellnex-telecom-historical-data

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

Шаги будут следующие: 1.- Цель состоит в том, чтобы скопироватьданные из таблицы «Исторические данные CLNX» в электронную таблицу Excel.2. Для загрузки необходимо предварительно выбрать «Ежемесячно» в раскрывающемся меню, позвонив «Срок».3.- Что загрузка производится путем предварительного выбора диапазона дат за последние 2 года.4.- Наконец, упорядочите таблицу в порядке убывания по столбцу «Максимум».5.- После выбора термина, диапазона дат и порядка скопируйте данные из таблицы «Исторические данные CLNX» в электронную таблицу Excel.

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

Может ли кто-нибудь мне помочь?

Спасибо за вашу помощь.

Код:

Sub DataInvesting()

Dim IE As Object

Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "https://www.investing.com/equities/cellnex-telecom-historical-data"

Do Until IE.readyState = 4

DoEvents

Loop

IE.Document.getElementsByClassName("newInput selectBox float_lang_base_1")(0).Value = "Monthly"

IE.Visible = True

Set IE = Nothing

Set appIE = Nothing

End Sub

Answer 1

Я только что протестировал следующий код, и он работает, вместо того, чтобы создавать экземпляр Internet Explorer каждый раз, когда нам нужно запустить этот макрос, мы будем использовать запросы xmlhttp.Просто скопируйте весь код и вставьте его в модуль в VBA.Не забудьте добавить ссылки (Инструменты / Ссылки) в библиотеку объектов Microsoft HTML и Microsoft XML v6.0.

Option Explicit
Sub Export_Table()

'Html Objects---------------------------------------'
 Dim htmlDoc As MSHTML.HTMLDocument
 Dim htmlBody As MSHTML.htmlBody
 Dim ieTable As MSHTML.HTMLTable
 Dim Element As MSHTML.HTMLElementCollection


'Workbooks, Worksheets, Ranges, LastRow, Incrementers ----------------'
 Dim wb As Workbook
 Dim Table As Worksheet
 Dim i As Long

 Set wb = ThisWorkbook
 Set Table = wb.Worksheets("Sheet1")

 '-------------------------------------------'
 Dim xmlHttpRequest As New MSXML2.XMLHTTP60  '
 '-------------------------------------------'


 i = 2

'Web Request --------------------------------------------------------------------------'
 With xmlHttpRequest
 .Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2017&end_date=03%2F01%2F2019&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"


 If .Status = 200 Then

        Set htmlDoc = CreateHTMLDoc
        Set htmlBody = htmlDoc.body

        htmlBody.innerHTML = xmlHttpRequest.responseText

        Set ieTable = htmlDoc.getElementById("curr_table")

        For Each Element In ieTable.getElementsByTagName("tr")
            Table.Cells(i, 1) = Element.Children(0).innerText
            Table.Cells(i, 2) = Element.Children(1).innerText
            Table.Cells(i, 3) = Element.Children(2).innerText
            Table.Cells(i, 4) = Element.Children(3).innerText
            Table.Cells(i, 5) = Element.Children(4).innerText
            Table.Cells(i, 6) = Element.Children(5).innerText
            Table.Cells(i, 7) = Element.Children(6).innerText

            i = i + 1
        DoEvents: Next Element
 End If
End With


Set xmlHttpRequest = Nothing
Set htmlDoc = Nothing
Set htmlBody = Nothing
Set ieTable = Nothing
Set Element = Nothing

End Sub

Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
    Set CreateHTMLDoc = CreateObject("htmlfile")
End Function

Answer 2

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

Ниже в общих чертах описываются шаги, которые я хотел бы рассмотреть, хотя, скорее всего, необходимы некоторые временные ожидания.

Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub Info()
    Dim ie As New InternetExplorer  
    Const URL As String  = ""https://www.investing.com/equities/cellnex-telecom-historical-data""
    With ie
        .Visible = True
        .Navigate2 URL

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.querySelector(".login").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        .Navigate2 URL

        While .Busy Or .readyState < 4: DoEvents: Wend


        With .document.querySelector("#loginFormUser_email")
            .Focus
            .Value = "Bob@gmail.com"
        End With
        With .document.querySelector("#loginForm_password")
            .Focus
            .Value = "systemSucksDoesn'tAcceptMyPassword"
        End With

        Application.Wait Now + TimeSerial(0, 0, 2)

        .document.querySelector("[onclick*=submitLogin]").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.querySelector("#data_interval").Click
        .document.querySelector("[value=Monthly]").Click
        With .document.querySelector("#picker")
            .Focus
            .Value = "03/08/2017 - 03/08/2019"
            .FireEvent "onchange"
        End With

        'TODO Sorting column when clarified which column
        .document.querySelector("[title='Download Data']").Click

        Application.Wait Now + TimeSerial(0, 0, 10)

        Stop
        .Quit
    End With
End Sub

Answer 3

Попробуйте это.

Sub Web_Table_Option()
    Dim HTMLDoc As New HTMLDocument
    Dim objTable As Object
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    objIE.Navigate "https://www.investing.com/equities/cellnex-telecom-historical-data"

    Do Until objIE.ReadyState = 4 And Not objIE.Busy
        DoEvents
    Loop
    Application.Wait (Now + TimeValue("0:00:03")) 'wait for java script to load
    HTMLDoc.body.innerHTML = objIE.Document.body.innerHTML
    With HTMLDoc.body
        Set objTable = .getElementsByTagName("curr_table")
        For lngTable = 0 To objTable.Length - 1
            For lngRow = 0 To objTable(lngTable).Rows.Length - 1
                For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                    ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
            ActRw = ActRw + objTable(lngTable).Rows.Length + 1
        Next lngTable
    End With
    objIE.Quit
End Sub