为什么代码没有从网页接收数据？

Question

Sub Yarislar()
    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", "Cins", "Grup", "Msf/Pist", "Derece", "Sira", "Jokey", "Kilo", "GC", "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 = 11
    Const numTableColumns As Long = 15
    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")
        For Each tRow In tRows
            If Not headerRow Then
                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

为什么我修改@Qharr 的代码无法从同一网页检索其他数据？ @QHarr 为“Galoplar”数据编写的代码完美运行，但是当我修改相同的代码时，它不适用于“Yarislar”。我是不是选桌有误？

Link

Answer 1

您缺少类定义。我认为，您还需要不同的 URL 结构。您没有提供，但基于您之前的问题，并且有点想象力，您需要添加以下 URL 结构：

BASE_URL & asay & /name

例如

https://yenibeygir.com/at/10221/dorukhatun

因此，源表中的 A 列的名称必须与检测 ID 一致，即必须包含诸如 10221/dorukhatun 之类的字符串。

您还必须调整控制表格中行号和列号的常量。

您需要适当调整源列 A 的范围。

我使用了我记得的两个 id，并在 A1:A2 中有以下内容（请注意，一些结果现在出现在工作表中，因为有测试运行）

表 1：

VBA：

类 clsHTTP：

Option Explicit
Private http As Object

Private Sub Class_Initialize()
    Set http = CreateObject("MSXML2.XMLHTTP")
End Sub

Public Function GetString(ByVal url As String) As String
    Dim sResponse As String
    With http
        .Open "GET", url, False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
        GetString = sResponse
    End With
End Function

标准模块 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", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
    Set http = New clsHTTP
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set html = New HTMLDocument
    asays = Application.Transpose(ws.Range("A1:A2").Value) 'Load asay values from sheet 1

    Const numTableRows As Long = 44
    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")

        For Each tRow In tRows
            If Not headerRow Then
                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, 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