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

也许类似的东西可能有用：

another_list = list()
for index, a in enumerate(a_list):      
  another_list.append([x[index] for x in a_list])  # IndexError

我可能是错的，但是列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中是否不应该包含“遥远的目标”？我假设“ A SCR AVG”中的“ A”代表“ Away”（因为“ H SCR AVG”中的“ H”似乎代表“ Home”）。因此，即使屏幕截图显示应该将它们写到E列中，我还是在列E上写了“离开目标”（或者可能我没有正确阅读）。

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

2 个答案: