从网络导入数据时，如何获取带有链接的数据？

Question

Precious @QHarr 编写的这段代码（与其他代码一样）运行良好。但是，在导入数据时，我想检索保存在连接中的数据。代码的输出和我想要接收的数据显示在附图中。我可以解决什么样的代码？ （谷歌翻译）

    Public Sub DYarislar()
    Dim asays(), ws As Worksheet, asay As Long, html As HTMLDocument
    Dim http As clsHTTP, url As String, headers(), numberOfRequests As Long

    headers = Array("Asay", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
    Set http = New clsHTTP
    Set ws = ThisWorkbook.Worksheets("X")


    Set html = New HTMLDocument
    asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)

    Const numTableRows As Long = 250
    Const numTableColumns As Long = 14
    Const BASE_URL As String = "https://yenibeygir.com/at/"

    numberOfRequests = UBound(asays)

    Dim results(), headerRow As Boolean, tRows As Object, tRow As Object, iRow As Long
    Dim tCells As Object, tCell As Object, r As Long, c As Long, hTable As HTMLTable
    ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)

    Application.ScreenUpdating = False

    For asay = 1 To numberOfRequests
        headerRow = True
        url = BASE_URL & asays(asay)
        html.body.innerHTML = http.GetString(url)

        Set hTable = html.querySelector(".at_Yarislar")

        Set tRows = hTable.getElementsByTagName("tr")

        Const numberOfRaces As Long = 22
        Dim counter As Long
        counter = 1
        For Each tRow In tRows
            If Not headerRow Then
                counter = counter + 1
                If counter > numberOfRaces Then Exit For
                c = 2: r = r + 1
                results(r, 1) = asays(asay)
                Set tCells = tRow.getElementsByTagName("td")
                For Each tCell In tCells
                    results(r, c) = tCell.innerText
                    c = c + 1
                Next
            End If
            headerRow = False
        Next
    Next

    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
    Application.ScreenUpdating = True

End Sub

Answer 1

您只需要进行一些小改动。您使用与以前相同的 Class，clsHTTP，然后使用下面的模块 1 代码。

---

注意事项：

在每个源页表行中，jockey 列包含一个a 标记链接元素

您可以使用以下方式访问它：

tRow.getElementsByTagName("a")(1).href

由于链接是相对的，您需要进行文本替换以添加到 URL 的基本部分，即

Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)

id 是href 的一部分，可以使用Split 提取：

Split(tRow.getElementsByTagName("a")(1).href, "/")(2)

要在结果中允许这些附加元素，您需要增加输出列数：

Const numTableColumns As Long = 16

并调整您的表格行循环以填充其他列：

results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2) 
results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)

此外，在循环中进行调整以确保从第 4 列开始填充其他列（作为 2 个额外列）：

c = 4

最后，调整标题以包含 2 个新列：

headers = Array("Asay", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")

---

VBA：

模块 1：

Option Explicit    
Public Sub DYarislar()
    Dim asays(), ws As Worksheet, asay As Long, html As HTMLDocument
    Dim http As clsHTTP, url As String, headers(), numberOfRequests As Long

    headers = Array("Asay", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
    Set http = New clsHTTP
    Set ws = ThisWorkbook.Worksheets("X")
    Set html = New HTMLDocument
    asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)

    Const numTableRows As Long = 250
    Const numTableColumns As Long = 16
    Const BASE_URL As String = "https://yenibeygir.com/at/"
    Const BASE_URL2 As String = "https://yenibeygir.com"
    numberOfRequests = UBound(asays)

    Dim results(), headerRow As Boolean, tRows As Object, tRow As Object, iRow As Long
    Dim tCells As Object, tCell As Object, r As Long, c As Long, hTable As HTMLTable
    ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)

    Application.ScreenUpdating = False

    For asay = 1 To numberOfRequests
        headerRow = True
        url = BASE_URL & asays(asay)
        html.body.innerHTML = http.GetString(url)

        Set hTable = html.querySelector(".at_Yarislar")

        Set tRows = hTable.getElementsByTagName("tr")

        For Each tRow In tRows
            If Not headerRow Then
                c = 4: r = r + 1
                results(r, 1) = asays(asay)
                On Error Resume Next
                results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
                results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
                On Error GoTo 0
                Set tCells = tRow.getElementsByTagName("td")
                For Each tCell In tCells
                    results(r, c) = tCell.innerText
                    c = c + 1
                Next
            End If
            headerRow = False
        Next
    Next

    With ws
        .Cells(1, 3).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 3).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
    Application.ScreenUpdating = True
End Sub

---

示例结果：