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

我想从betexplorer.com提取数据。我想从以下URL提取两个不同的数据：https://www.betexplorer.com/soccer/s...eague-1/stats/我想提取玩过的比赛和剩余的比赛我想提取主场进球数和客场进球数（每次比赛）我有执行此操作的代码，如下所示：Option ExplicitSub GetSoccerStats()'Set a reference (VBE > Tools > References) to the following libraries:' 1) Microsoft XML, v6.0' 2) Microsoft HTML Object LibraryDim xmlReq As New MSXML2.XMLHTTP60Dim objDoc As New MSHTML.HTMLDocumentDim objTable As MSHTML.htmlTableDim objTableRow As MSHTML.htmlTableRowDim strURL As StringDim strResp As StringDim strText As StringDim rw As LongstrURL = "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 = .responseTextEnd WithWorksheets.AddobjDoc.body.innerHTML = strRespSet 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").AutoFitEnd IfSet xmlReq = NothingSet objDoc = NothingSet objTable = NothingSet objTableRow = NothingEnd Sub此代码有效，但是我想更进一步。我实际上想为同一站点上的许多不同URL运行此宏。我已经创建了一个工作表，该工作表具有一个足球联盟列表（在行中），列中包含数据。您可以在这里找到文件：https://www.dropbox.com/s/77sol24sty75w5z/Avg%20Goals.xlsm?dl=0这是我将在其中将联赛添加到行中的文件。是否可以修改提取数据的代码，以便可以填充工作表中的列？我不需要像该代码那样输入数据名称（剩余比赛数，主场进球，客场进球等），我只需要数字即可。提取的数字将必须按照工作表填充列（因此，每一行都包含每个联赛的数据。如您所见，有几个联赛，因此需要遍历每一行，然后使用相应的URL行。您会发现有一个包含单词CURRENT的列。这表明它应使用“当前URL”列中的URL。如果我将值更改为LAST，则希望它使用Last URL列中的URL。对于每个联赛，如果我使用CURRENT或LAST，将有所不同。这是预期输出的图片：任何帮助是极大的赞赏。 最佳答案 与您的代码保持一致，这将在M：T列中输出这些项目的数据。我有一个辅助函数GetLinks，它根据K列中的值生成要使用的最终URL数组：inputArray = GetLinks(inputArray)该数组被循环，并发出xhr请求以获取该信息。所有结果信息都存储在数组results中，该数组一次写到末尾的工作表中。我一直在使用数组，因为您不想一直从表中读取内容；这是一项昂贵的操作，会使您的代码变慢。出于同样的原因，如果出现 200，则将消息和URL打印到立即窗口，以免降低代码速度。您实际上有一个日志，然后可以在末尾查看。检索到的结果从M列中写出，但是由于数据在数组中，因此您可以轻松地将其写到所需位置。只需将粘贴的起始单元格从M4更改为所需的最左边单元格即可。您现有的列中没有百分比，因此可以放心地假设您希望写入的数据位于新列中（甚至可能在其他工作表中）。Option ExplicitPublic 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)) = resultsEnd SubPublic 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 = inputArrayEnd Function文件布局：鉴于大量请求导致阻止，此处是IE版本：'VBE > Tools > References:'1: Microsoft HTML Object library 2: Microsoft Internet ControlsPublic 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)) = resultsEnd Sub