如何从网站提取数据并使用VBA填写Excel表格？

Question

我想从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行。

您会注意到有一列包含单词CURRENT。这表示它应该使用“当前URL”列中的URL。如果我将值更改为LAST，我希望它使用Last URL列中的URL。

对于每个联赛，如果我使用CURRENT或LAST，则会有所不同。

这是预期输出的图片：

任何帮助是极大的赞赏。

Answer 1

与您的代码保持一致，这将在M：T列中输出这些项目的数据。我有一个辅助函数GetLinks，它根据K列中的值生成一个最终url数组：

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

Answer 2

也许这样的事可能会奏效：

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 SCR AVG”中的“A”代表“Away”（因为“H SCR AVG”中的“H”似乎代表“Home”）。所以我写了“离开目标”到列E，即使截图表明他们应该写入列B（或者我可能没有正确阅读）。