如何修复Excel VBA QueryTables不从网站提取数据

Question

我过去曾使用这段代码从ESPN中为我的幻想棒球联盟中的名单提取数据。我能够获得名单并将它们全部放在Excel中的一列中。然后做一些格式化。但现在，无法提取数据。没有任何表现。 ESPN确实改变了他们的网站看起来不同，所以我倾向于认为这会影响这段代码的工作方式。

到目前为止我在代码中尝试更改的内容：更改所有三种类型的“.WebSelectionType”（xlSpecifiedTables，xlAllTables，xlEntirepage）;尝试了不同的.WebTables值。

- 这个“.QueryTable”命令仍会在这个网址上运行吗？ - 我是否必须使用不同的命令/代码从该URL中删除表格？

Sheet11.Range("h:p").ClearContents  'clear old data
url = "URL;http://fantasy.espn.com/baseball/league/rosters?leagueId=101823"

With Sheet11.QueryTables.Add(Connection:= _
    url, Destination:=Range("$h$1"))
    .Name = "MyESPNRoster"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = False
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebTables = "3,4,5,6,7,8,9,10,11,12,13,14"    'the table number to get the right table of data. there should be 12 rosters
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = True
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

Answer 1

几乎所有这些信息（我认为实际上更多）都可以从他们的API的json响应中获得。以下是团队和名称的示例。你需要使用json parser。从提供给项目的链接添加.bas后，添加如下所示的参考。

通过使用Alt + F11打开VBE，右键单击项目区域并添加模块，为项目添加标准模块。然后将代码粘贴到模块中模块1。

在VBA Json结构中，[]表示通过索引或For Each over访问的集合。 {}是按键访问的字典，其他一切都是字符串文字。

Option Explicit
'  VBE > Tools > References > Microsoft Scripting Runtime
Public Sub GetPlayers()
    Dim json As Object, ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.ClearContents

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://fantasy.espn.com/apis/v3/games/flb/seasons/2019/segments/0/leagues/101823?view=mSettings&view=mRoster&view=mTeam&view=modular&view=mNav", False
        .send
        Set json = JsonConverter.ParseJson(.responseText)
    End With

    Dim item As Object, nextItem As Object, r As Long, c As Long
    c = 0
    For Each item In json("teams")
        r = 1: c = c + 1
        ws.Cells(r, c) = item("location") & " " & item("nickname")
        For Each nextItem In item("roster")("entries")
            r = r + 1
            ws.Cells(r, c) = nextItem("playerPoolEntry")("player")("fullName")
        Next
    Next
End Sub

---

json的样本（1名球员信息）：

以下只是为每个团队成员检索的所有信息的一小部分样本（太多不能全部显示）

---

输出样本：