Придерживаясь вашего кода, вы получите данные для этих элементов в столбцах 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