使用 Excel VBA 进行网页抓取

Question

如何从Here 中提取表格数据？

我可以看到每一行都包含在“团队名称优先”类中。我想将表格导入 excel，但使用来自 web 选项我无法在 IE 窗口中看到表格。我认为 VBA 是我需要采取的途径。我尝试了一些谷歌搜索和 youtube 教程，但没有任何成功。任何帮助将不胜感激！

snip

**编辑 抱歉，我以为我附上了我的代码。问题是它没有加载整个页面。所以我认为这就是我无法提取数据的原因。

There should be a table showing here

Sub FetchNBADefense()

Dim IE As Object, obj As Object
Dim r As Long, c As Long, t As Long
Dim elemCollection As Object
Dim eRow As Long


Set IE = CreateObject("InternetExplorer.Application")

With IE

.Visible = True
.navigate ("https://stats.nba.com/teams/opponent/?sort=W&dir=-1")



While IE.readyState <> 4
    DoEvents
Wend

ThisWorkbook.Sheets("TeamDefenses").Range("A1:M60").ClearContents
Set elemColleciton = IE.document.getElementsByTagName("team-name first")
For t = 0 To (elemCollection.Length - 1)
    For r = 0 To (elemCollection(t).Rows.Cells.Length - 1)
        For c = 0 To (elemCollection(t).Rows(r).Cells.Length - 1)
        eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

        ThisWorkbook.Worksheets(1).Cells(eRow, c + 1) = elemCollection(t).Rows(r).Cells(c).innerText
        Next c
    Next r
Next t

End With
Range("A1:M60").Columns.AutoFit
'Clear memory
Set IE = Nothing

End Sub

***新代码：我错过了什么？我看到它是“resultSet”而不是“resultSets”，但仍然出现运行时错误“424”：需要对象

Option Explicit

Public Sub FetchNBAplayerpts()

Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

Dim json As Object
With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "https://stats.nba.com/stats/leagueLeaders?LeagueID=00&PerMode=PerGame&Scope=S&Season=2018-19&SeasonType=Regular+Season&StatCategory=PTS", False
    .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
    .send
    Set json = JsonConverter.ParseJson(.responseText)("resultSet")(1)
End With
Dim headers As Object, header As Variant, headerOutput(), i As Long, rowInfo As Object, iRow As Object
Set headers = json("headers")
Set rowInfo = json("rowSet")
ReDim headerOutput(1 To headers.Count)
For Each header In headers
    i = i + 1
    headerOutput(i) = header
Next

Dim rowData(), r As Long, c As Long, Item As Variant
ReDim rowData(1 To rowInfo.Count, 1 To UBound(headerOutput))

For Each iRow In rowInfo
    r = r + 1: c = 1
    For Each Item In iRow
        rowData(r, c) = Item
    c = c + 1
    Next
Next

With ThisWorkbook.Worksheets("PlayerPts")
    .Cells(1, 1).Resize(1, UBound(headerOutput)) = headerOutput
    .Cells(2, 1).Resize(UBound(rowData, 1), UBound(rowData, 2)) = rowData
End With

End Sub

Answer 1

从与@TylerH 和@LuckyKleinschmidt 的讨论来看，该页面似乎使用了 IE 不支持的 javascript 方法 includes 。这可能是页面没有完全呈现的原因，因为脚本没有运行。见here。解决方法是在相关脚本中使用indexOf 方法。我猜开发者并不担心 IE 的小市场份额。

Browser support:

如果您碰巧在 Chrome/Firefox 开发工具中进行检查，或者使用诸如 fiddler 之类的网络流量监控工具，您会看到实际上发送了一个 XMLHTTP request 以将数据检索到不同的来源，而实际上您可以使用该 URL 发出 XMLTTP 请求。这是一种比打开浏览器更快的检索方法，因此在这种情况下是一种胜利。响应是一个 JSON 响应，可以使用 JSON 解析器处理。我使用JSONConverter.bas，您可以将其下载并添加到您的项目中。

将上述链接中的.bas 添加到您的项目后，您可以通过 VBE > Tools > References > Microsoft Scripting Runtime 添加引用。

JSON 响应具有以下结构（示例）：

{ 表示字典，因此您可以通过键访问，[ 表示集合，因此您可以通过索引访问（或者，For Each 就像我一样）。 "" 表示字符串文字，因此您可以按原样阅读。根据需要测试数据类型和句柄。

此方法检索到的信息多于页面上可见的信息。

输出样本：

---

VBA：

Option Explicit    
Public Sub GetTable()       
    Dim json As Object
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://stats.nba.com/stats/leaguedashteamstats?Conference=&DateFrom=&DateTo=&Division=&GameScope=&GameSegment=&LastNGames=0&LeagueID=00&Location=&MeasureType=Opponent&Month=0&OpponentTeamID=0&Outcome=&PORound=0&PaceAdjust=N&PerMode=PerGame&Period=0&PlayerExperience=&PlayerPosition=&PlusMinus=N&Rank=N&Season=2018-19&SeasonSegment=&SeasonType=Regular+Season&ShotClockRange=&StarterBench=&TeamID=0&VsConference=&VsDivision=", False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        Set json = JsonConverter.ParseJson(.responseText)("resultSets")(1)
    End With
    Dim headers As Object, header As Variant, headerOutput(), i As Long, rowInfo As Object, iRow As Object
    Set headers = json("headers")
    Set rowInfo = json("rowSet")
    ReDim headerOutput(1 To headers.Count)
    For Each header In headers
        i = i + 1
        headerOutput(i) = header
    Next

    Dim rowData(), r As Long, c As Long, item As Variant
    ReDim rowData(1 To rowInfo.Count, 1 To UBound(headerOutput))

    For Each iRow In rowInfo
        r = r + 1: c = 1
        For Each item In iRow
            rowData(r, c) = item
            c = c + 1
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet1")
        .Cells(1, 1).Resize(1, UBound(headerOutput)) = headerOutput
        .Cells(2, 1).Resize(UBound(rowData, 1), UBound(rowData, 2)) = rowData
    End With

End Sub

---

开发工具（网络选项卡）中的 XHR 请求：