Как получить данные со ссылками при импорте данных из Интернета?

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)

Идентификатор является частью 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

---

СбНесколько результатов: