Информация о списках VBA HTML Pull в ссылках

Question

У меня есть список из примерно 150 URL-адресов (все для Swappa.com/xxxxxx), из которых я хотел бы получить информацию. Я выяснил, как вытащить первый листинг из каждого, но я хочу расширить его, чтобы вытащить все листинги для каждого URL и загрузить их в одну таблицу (друг над другом).

Образец ниже:

Пример URL: https://swappa.com/mobile/buy/apple-iphone-6s/sprint или же https://swappa.com/mobile/buy/samsung-galaxy-s6/t-mobile

Желаемые данные:

Public Sub ListingInfo()
Dim cell As Range
With ThisWorkbook.Worksheets("Sheet1")
    For Each cell In .Range("A1", .Cells(.Rows.count, 1).End(xlUp))
        Dim Document As MSHTML.HTMLDocument
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", cell.Value, False
            .send
            Set Document = New MSHTML.HTMLDocument
            Document.body.innerHTML = .responseText
        End With
        cell.Offset(0, 1).Value = Document.querySelector(".text-nowrap").innerText
        cell.Offset(0, 2).Value = 
Document.querySelector("condition_label").innerText
        cell.Offset(0, 3).Value = 
Document.querySelector("price").innerText
        cell.Offset(0, 4).Value = 
Document.querySelector("storage_label").innerText
        cell.Offset(0, 5).Value = 
Document.querySelector("color_label").innerText
    Next
End With
End Sub

Answer 1

Сайт использует CloudFlare для защиты от DDoS / DoS. Это означает, что вы почти наверняка закончите с ошибкой xmlhttp, поскольку перенаправление будет происходить довольно быстро, и вы не получите ожидаемый контент во время циклов URL.

Вам также необходимо обработать не найденные страницы и задержать перенаправление CloudFlare, если это произойдет.

Следующие данные предназначены для тех, кто, возможно, захочет добавить в некоторых тестах, что в столбце A действительно есть URL-адреса. Я предполагаю, что URL-адреса находятся в столбце A листа sheet1, и эта информация записывается, начиная со столбца B. Я использую массивы для ускорить работу, а также обработку ошибок и указание на то, что не вся информация, которую вы хотите, может присутствовать на каждой странице / для каждого списка.

Option Explicit   
Public Sub GetResults()
    Dim html As HTMLDocument, page As Long, ws As Worksheet, index As Long
    Dim results(), URLs(), ie As InternetExplorer, t As Date
    Const MAX_WAIT_SEC As Long = 15

    Application.ScreenUpdating = False

    Set ie = New InternetExplorer
    Set html = New HTMLDocument
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    URLs = Application.Transpose(ws.Range("A1:A2").Value)
    ReDim results(1 To UBound(URLs))

    With ie
        .Visible = True
        For page = LBound(URLs) To UBound(URLs)
            If InStr(URLs(page), "http") > 0 Then
                .Navigate2 URLs(page)

                While .Busy Or .readyState < 4: DoEvents: Wend
                t = Timer
                Do
                    If Timer - t > MAX_WAIT_SEC Then Exit Do
                Loop While .document.querySelectorAll("#section_main").Length = 0

                If Not InStr(.document.body.innerHTML, "404 - Sorry, we couldn't find what you were looking for. ") > 0 And _
                   Not InStr(.document.body.innerHTML, "No listings currently for sale") > 0 Then
                    index = index + 1
                    results(index) = GetInfo(.document, URLs(page))
                Else
                    ReDim Preserve results(1 To UBound(results) - 1)
                End If
            End If
        Next
        .Quit
    End With

    Dim i As Long, j As Long, rowCounter As Long, arr()

    rowCounter = 1
    Dim headers()
    headers = Array("URL", "Seller", "Feedback", "Condition", "Color", "Storage", "Price", "Headline")
    ws.Cells(1, 2).Resize(1, UBound(headers) + 1) = headers
    For i = LBound(results) To UBound(results)
        arr = results(i)
        For j = LBound(arr) To UBound(arr)
            rowCounter = rowCounter + 1
            ws.Cells(rowCounter, 2).Resize(1, UBound(arr(j)) + 1) = arr(j)
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Public Function GetInfo(ByVal html As HTMLDocument, ByVal url As String) As Variant
    Dim dict As Object, results(), nodeList, numSellers As Long, counter As Long
    Dim listings As Object, listing As Object, ws As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    dict.Add "URL", url
    dict.Add "Seller", vbNullString
    dict.Add "Feedback", vbNullString
    dict.Add "Condition", vbNullString
    dict.Add "Color", vbNullString
    dict.Add "Storage", vbNullString
    dict.Add "Price", vbNullString
    dict.Add "Headline", vbNullString

    Set listings = html.getElementById("section_main").getElementsByClassName("listing_row listing_None listing_None")
    ReDim results(1 To listings.Length)

    For Each listing In listings
        counter = counter + 1
        On Error Resume Next
        dict("Seller") = listing.querySelector(".text-nowrap").innerText
        dict("Feedback") = listing.querySelector("[data-value]").getAttribute("data-value")
        dict("Condition") = listing.querySelector(".condition_label").innerText
        dict("Color") = listing.querySelector(".color_label").innerText
        dict("Storage") = listing.querySelector(".storage_label").innerText
        dict("Price") = listing.querySelector(".price").innerText
        dict("Headline") = listing.querySelector(".headline.hidden-xs.text-nowrap").innerText
        On Error GoTo 0
        results(counter) = dict.Items
        Set dict = ClearDict(dict)
    Next
    GetInfo = results
End Function

Public Function ClearDict(ByRef dict As Object) As Object
    Dim key As Variant
    For Each key In dict
        If key <> "URL" Then dict(key) = vbNullString
    Next
    Set ClearDict = dict
End Function

---

Ссылка:

1. Библиотека объектов Microsoft HTML
2. Microsoft Internet Controls

Answer 2

Следующий скрипт должен получить содержимое, которое вы хотите получить с первого URL.

Public Sub GetListingInfo()
    Const Url$ = "https://swappa.com/mobile/buy/apple-iphone-6s/sprint"
    Dim HTTP As New XMLHTTP60, HTML As New HTMLDocument
    Dim post As HTMLDivElement, I&

    With HTTP
        .Open "GET", Url, False
        .send
        HTML.body.innerHTML = .responseText
    End With

    For Each post In HTML.getElementsByClassName("listing_row")
        I = I + 1: Cells(I, 1) = post.querySelector(".text-nowrap span").innerText
        Cells(I, 2) = post.querySelector(".condition_label").innerText
        Cells(I, 3) = post.querySelector(".price").innerText
        Cells(I, 4) = post.querySelector(".storage_label").innerText
        Cells(I, 5) = post.querySelector(".color_label").innerText
    Next post
End Sub

Ссылка для добавления:

Microsoft xml, v6.0
Microsoft HTML Object Library