Как я могу извлечь данные с веб-сайта и заполнить лист Excel с помощью VBA?

Я хотел бы извлечь данные из betexplorer.com. Я хочу извлечь две разные части данных из следующего URL-адреса:

https://www.betexplorer.com/soccer/s...eague-1/stats/

Я хотел бы извлечь данные о сыгранных и оставшихся матчах Я хотел бы извлечь данные о головах дома и на выезде (за матч)

У меня есть код для этого, и он выглядит следующим образом:

Option Explicit

Sub GetSoccerStats()


'Set a reference (VBE > Tools > References) to the following libraries:
'   1) Microsoft XML, v6.0
'   2) Microsoft HTML Object Library

Dim xmlReq As New MSXML2.XMLHTTP60
Dim objDoc As New MSHTML.HTMLDocument
Dim objTable As MSHTML.htmlTable
Dim objTableRow As MSHTML.htmlTableRow
Dim strURL As String
Dim strResp As String
Dim strText As String
Dim rw As Long

strURL = "https://www.betexplorer.com/soccer/south-korea/k-league-1/stats/"

With xmlReq
    .Open "GET", strURL, False
    .send
    If .Status <> 200 Then
        MsgBox "Error " & .Status & ":  " & .statusText
        Exit Sub
    End If
    strResp = .responseText
End With

Worksheets.Add

objDoc.body.innerHTML = strResp

Set objTable = objDoc.getElementsByClassName("table-main leaguestats")(0)

If Not objTable Is Nothing Then
    rw = 1
    For Each objTableRow In objTable.Rows
        strText = objTableRow.Cells(0).innerText
        Select Case strText
            Case "Matches played", "Matches remaining", "Home goals", "Away goals"
                Cells(rw, "a").Value = objTableRow.Cells(0).innerText
                Cells(rw, "b").Value = objTableRow.Cells(1).innerText
                Cells(rw, "c").Value = objTableRow.Cells(2).innerText
                rw = rw + 1
        End Select
    Next objTableRow
    Columns("a").AutoFit
End If

Set xmlReq = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Set objTableRow = Nothing


End Sub

Этот код работает, однако я хочу сделать еще один шаг.

Я действительно хочу запустить этот макрос для многих разных URL-адресов на одном сайте. У меня уже есть рабочий лист со списком футбольных лиг (в строках), столбцы содержат данные.

Вы можете найти файл здесь: https://www.dropbox.com/s/77sol24sty75w5z/Avg%20Goals.xlsm?dl=0

Это файл, в котором я буду добавлять лиги к строкам по мере продвижения. Можно ли адаптировать код, который извлекает данные, чтобы он мог заполнять столбцы на моем листе? Мне не нужно вводить имена данных (оставшиеся матчи, домашние голы, голы на выезде и т. д.), как это делает этот код, мне нужны только цифры. Извлеченные цифры должны будут заполнить столбцы в соответствии с листом (таким образом, каждая строка содержит данные для каждой лиги. Как вы можете видеть, есть несколько лиг, поэтому необходимо будет пройтись по каждой строке, а затем использовать соответствующий URL-адрес для этого ряд.

Вы заметите, что есть столбец, содержащий слово ТЕКУЩИЙ. Это указывает на то, что он должен использовать URL-адрес в столбце Текущий URL-адрес. Если я изменю значение на ПОСЛЕДНИЙ, я бы хотел, чтобы он использовал URL-адрес в столбце Последний URL-адрес.

Для каждой лиги будет по-разному, если я использую ТЕКУЩАЯ или ПОСЛЕДНЯЯ.

Вот изображение ожидаемого результата:

ожидаемый результат

Любая помощь приветствуется.


person MA84    schedule 27.04.2019    source источник
comment
Небольшой макет ожидаемого вывода, включая вопрос, возможно, поможет показать первую пару строк вывода. Это можно было бы вставить как изображение.   -  person QHarr    schedule 27.04.2019
comment
И в чем разница между текущим и последним URL? У вас есть примеры каждого?   -  person QHarr    schedule 27.04.2019
comment
Мы должны быть в состоянии ответить на этот вопрос, не обращаясь к внешнему файлу. Тем не менее: ваш файл Dropbox общедоступен? Я вижу 404 не найдено   -  person QHarr    schedule 27.04.2019
comment
Я обновил ссылку и добавил фото   -  person MA84    schedule 27.04.2019


Ответы (2)


В соответствии с вашим кодом данные для этих элементов будут выводиться в столбцах M:T. У меня есть вспомогательная функция GetLinks, которая генерирует массив конечных URL-адресов для использования на основе значения в столбце K:

inputArray = GetLinks(inputArray)

Этот массив зацикливается, и для получения информации выдаются запросы xhr. Вся информация о результатах хранится в массиве results, который за один раз выписывается на лист в конце.

Я работаю с массивом повсюду, так как вы не хотите продолжать читать с листа; это дорогостоящая операция, которая замедляет ваш код. По той же причине, если встречается ‹> 200, я печатаю в ближайшее окно сообщение и URL-адрес, чтобы не замедлять код. У вас фактически есть журнал, который вы можете просмотреть в конце.

Полученные результаты записываются из столбца M, но, поскольку данные находятся в массиве, вы можете легко записать их в любое место; просто измените начальную ячейку для вставки с M4 на любую верхнюю левую ячейку, которую вы хотите. В ваших существующих столбцах нет процентов, поэтому я с уверенностью могу предположить, что вы ожидаете, что выписанные данные будут в новых столбцах (возможно, даже на другом листе).

Option Explicit   
Public Sub GetSoccerStats()
    Dim xmlReq As New MSXML2.XMLHTTP60, response As String
    Dim objDoc As New MSHTML.HTMLDocument, text As String
    Dim lastRow As Long, dataSheet As Worksheet, inputArray(), i As Long

    Set dataSheet = ThisWorkbook.Worksheets("AVG GOAL DATA")

    With dataSheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    inputArray = dataSheet.Range("J4:L" & lastRow).Value
    inputArray = GetLinks(inputArray)

    Dim results(), r As Long, c As Long
    ReDim results(1 To UBound(inputArray, 1), 1 To 8)

    With xmlReq

        For i = LBound(inputArray, 1) To UBound(inputArray, 1)
            r = r + 1
            .Open "GET", inputArray(i, 4), False
            .send
            If .Status <> 200 Then
                Debug.Print inputArray(i, 4), vbTab, "Error " & .Status & ":  " & .statusText
            Else
                response = .responseText
                objDoc.body.innerHTML = response

                Dim objTable As MSHTML.HTMLTable, objTableRow As MSHTML.HTMLTableRow

                Set objTable = objDoc.getElementsByClassName("table-main leaguestats")(0)

                If Not objTable Is Nothing Then
                    c = 1
                    For Each objTableRow In objTable.Rows
                        text = objTableRow.Cells(0).innerText
                        Select Case text
                        Case "Matches played", "Matches remaining", "Home goals", "Away goals"
                            results(r, c) = objTableRow.Cells(1).innerText
                            results(r, c + 1) = objTableRow.Cells(2).innerText
                            c = c + 2
                        End Select
                    Next objTableRow
                End If
            End If
            Set objTable = Nothing
        Next
    End With
    dataSheet.Range("M4").Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

Public Function GetLinks(ByRef inputArray As Variant) As Variant
    Dim i As Long
    ReDim Preserve inputArray(1 To UBound(inputArray, 1), 1 To UBound(inputArray, 2) + 1)

    For i = LBound(inputArray, 1) To UBound(inputArray, 1)
        inputArray(i, 4) = IIf(inputArray(i, 1) = "CURRENT", inputArray(i, 2), inputArray(i, 3))
    Next
    GetLinks = inputArray
End Function

Макет файла:

введите здесь описание изображения


Учитывая большое количество запросов, приведших к блокировке, вот версия IE:

'VBE > Tools > References:
'1: Microsoft HTML Object library  2: Microsoft Internet Controls
Public Sub GetSoccerStats()
    Dim ie As Object, t As Date
    Dim objDoc As New MSHTML.HTMLDocument, text As String
    Dim lastRow As Long, dataSheet As Worksheet, inputArray(), i As Long

    Const MAX_WAIT_SEC As Long = 10

    Set dataSheet = ThisWorkbook.Worksheets("AVG GOAL DATA")
    Set ie = CreateObject("InternetExplorer.Application")
    With dataSheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    inputArray = dataSheet.Range("C4:E" & lastRow).Value
    inputArray = GetLinks(inputArray)

    Dim results(), r As Long, c As Long
    ReDim results(1 To UBound(inputArray, 1), 1 To 8)

    With ie
        .Visible = True
        For i = LBound(inputArray, 1) To UBound(inputArray, 1)
            r = r + 1
            .navigate2 inputArray(i, 4)

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

            Dim objTable As MSHTML.HTMLTable, objTableRow As MSHTML.HTMLTableRow
            t = timer
            Do
                DoEvents
                On Error Resume Next
                Set objTable = .document.getElementsByClassName("table-main leaguestats")(0)
                On Error GoTo 0
                If Timer - t > MAX_WAIT_SEC Then Exit Do
            Loop While objTable Is Nothing

            If Not objTable Is Nothing Then
                c = 1
                For Each objTableRow In objTable.Rows
                    text = objTableRow.Cells(0).innerText
                    Select Case text
                    Case "Matches played", "Matches remaining", "Home goals", "Away goals"
                        results(r, c) = objTableRow.Cells(1).innerText
                        results(r, c + 1) = objTableRow.Cells(2).innerText
                        c = c + 2
                    End Select
                Next objTableRow
            End If
            Set objTable = Nothing
        Next
        .Quit
    End With
    dataSheet.Range("F4").Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
person QHarr    schedule 27.04.2019
comment
Привет, это работает хорошо, поэтому я обновил свой список лиг (теперь их более 70). Когда я запускаю макрос, я получаю следующую ошибку: Ошибка выполнения '-2147024891 (80070005): Отказано в доступе. В отладке ошибка находится в .send xmlreq - person MA84; 28.04.2019
comment
Скорее всего, сайт слишком быстро блокирует вас из-за слишком большого количества запросов. Возможно, вам придется ввести ожидания во время цикла. Вы хотите использовать тот же сайт и загрузить файл со всеми лигами для меня? - person QHarr; 28.04.2019
comment
Я думал, что это может быть проблема времени. Вот ссылка на файл dropbox.com/s/77sol24sty75w5z /Avg%20Goals.xlsm?dl=0 - person MA84; 28.04.2019
comment
Согласованный. Если он работает с одним/несколькими запросами, но не с большим количеством, вероятно, вас регулируют/блокируют. - person QHarr; 28.04.2019
comment
Это блокировка по IP. Даже при смене IP у него появляется еще один уровень защиты. Я предполагаю, что этот соскоб не допускается. - person QHarr; 28.04.2019
comment
Это количество запросов? Потому что для 4 лиг работало нормально. Я предполагаю, что должна быть минимальная задержка для каждого IP. Даже если процесс займет 5 минут, все будет в порядке. - person MA84; 28.04.2019
comment
После строки r = r + 1 вы можете попробовать добавить эту строку: If r mod 4 = 0 Then Application.Wait Now + TimeSerial(0,02) - person QHarr; 28.04.2019
comment
Что странно, что даже просто запустив его на 4 лиги я получаю ту же ошибку. Я попытался добавить строку, но получаю необязательную ошибку - person MA84; 28.04.2019
comment
Я думаю, что это меры безопасности для сайта. Возможно, вам придется переключиться на браузер и посмотреть, поможет ли это. - person QHarr; 28.04.2019
comment
Хорошо, отлично, когда вы имеете в виду переключение на браузер, вы имеете в виду запуск VBA с помощью браузера? - person MA84; 28.04.2019
comment
Да. Однако это будет медленнее. Вы должны очень мало изменить код выше, что является плюсом - person QHarr; 28.04.2019
comment
Это не будет проблемой в браузере, хотя я не знал, что мы можем запускать VBA в браузере. Не могли бы вы помочь мне реализовать это? Я могу расшифровать код VBA, но не очень понимаю, как его кодировать. Если нет, не потейте, я ценю всю помощь, которую вы уже оказали !!! - person MA84; 28.04.2019
comment
Я имею в виду, что вы бы автоматизировали браузер, чтобы сделать запрос. 1) Какие у вас браузеры? 2) Можете ли вы установить стороннее программное обеспечение с открытым исходным кодом? (1 программа под названием Selenium Basic) - person QHarr; 28.04.2019
comment
Я могу установить что угодно и использовать Chrome или Firefox (последние версии) - person MA84; 28.04.2019
comment
В порядке. Я напишу еще два сценария для вас. Один для IE и один для Chrome. - person QHarr; 28.04.2019
comment
Давайте продолжим обсуждение в чате. - person MA84; 28.04.2019

Может быть, что-то вроде этого может работать:

Option Explicit

Private Sub GetSoccerStats()

    'Set a reference (VBE > Tools > References) to the following libraries:
    '   1) Microsoft XML, v6.0
    '   2) Microsoft HTML Object Library

    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("AVG GOAL DATA")

    Dim firstRowToFetchDataFor As Long
    firstRowToFetchDataFor = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row + 1 ' Assumes a row needs pulling if the value in column C is blank.

    Dim lastRowToFetchDataFor As Long
    lastRowToFetchDataFor = sourceSheet.Cells(sourceSheet.Rows.Count, "B").End(xlUp).Row

    Dim xmlReq As MSXML2.XMLHTTP60
    Set xmlReq = New MSXML2.XMLHTTP60

    Dim htmlDoc As MSHTML.HTMLDocument
    Set htmlDoc = New MSHTML.HTMLDocument

    Dim rowIndex As Long
    For rowIndex = firstRowToFetchDataFor To lastRowToFetchDataFor

        Dim URL As String
        Select Case LCase$(sourceSheet.Cells(rowIndex, "J"))
            Case "current"
                URL = sourceSheet.Cells(rowIndex, "K")
            Case "last"
                URL = sourceSheet.Cells(rowIndex, "L")
            Case Else
                MsgBox "Expected 'current' or 'last', instead got '" & sourceSheet.Cells(rowIndex, "J") & "' in cell '" & sourceSheet.Cells(rowIndex, "J").Address(False, False) & "'.", vbCritical
                Application.Goto sourceSheet.Cells(rowIndex, "J")
                Exit Sub
        End Select

        With xmlReq
            .Open "GET", URL, False
            .send
            If .Status <> 200 Then
                MsgBox "Request returned HTTP " & .Status & ":" & vbNewLine & vbNewLine & .statusText, vbCritical
                Exit Sub
            End If
            htmlDoc.body.innerHTML = .responseText
        End With

        Dim htmlTableExtracted As MSHTML.HTMLTable
        On Error Resume Next
        Set htmlTableExtracted = htmlDoc.getElementsByClassName("table-main leaguestats")(0)
        On Error GoTo 0

        If Not (htmlTableExtracted Is Nothing) Then
            Dim tableRow As MSHTML.HTMLTableRow
            For Each tableRow In htmlTableExtracted.Rows
                Select Case LCase$(tableRow.Cells(0).innerText)
                    Case "matches played"
                        sourceSheet.Cells(rowIndex, "G") = tableRow.Cells(1).innerText
                    Case "matches remaining"
                        sourceSheet.Cells(rowIndex, "H") = tableRow.Cells(1).innerText
                    Case "home goals"
                        sourceSheet.Cells(rowIndex, "C") = tableRow.Cells(2).innerText
                    Case "away goals"
                        sourceSheet.Cells(rowIndex, "E") = tableRow.Cells(2).innerText
                End Select
            Next tableRow

            Set htmlTableExtracted = Nothing ' Prevent this iteration's result having effects on succeeding iterations
        End If
    Next rowIndex
End Sub

Я могу ошибаться, но разве столбец E не должен содержать "голы на выезде"? Я предположил, что «A» в «A SCR AVG» означает «Away» (поскольку «H» в «H SCR AVG», по-видимому, означает «Home»). Поэтому я пишу «Голы на выезде» в столбец E, хотя на скриншоте видно, что их следует записывать в столбец B (или, может быть, я неправильно читаю).

person chillin    schedule 27.04.2019
comment
По какой-то причине я не вижу, чтобы ваш макрос запускался, когда я вставляю его в модуль VBA. - person MA84; 28.04.2019