Question

Precious @QHarr编写的此代码（与其他代码一样）效果很好。但是，导入数据时，我想检索保存在连接中的数据。随附的图像中显示了我想接收的代码输出和数据。我可以解决哪种代码？（Google翻译）

    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

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

注释：

在每个源页面表行中，骑师栏包含一个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

样本结果：

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

1 个答案: