Web Scraping by Elements

Question

Я пытаюсь очистить данные с веб-страницы. Это не будет работать для веб-сайта, для которого весь формат такой же, как у класса, помечать все. Я получаю сообщение об ошибке «Нижний индекс вне диапазона», и оно выделяется кодом «ReDim results (1 To rowCount, 1 To numColumns)».

Я получил ответ на странице: Web Scraping by TagName код отлично работает для https://www.neighborhoodselfstorage.net/self-storage-ocean-city-md-88769

Теперь я пытаюсь использовать тот же код для: https://www.stormore.net/self-storage-seattle-wa-101616#utm_source=GoogleLocal&utm_medium=WRLocal&utm_campaign=101616

Пожалуйста, помогите решить эту проблему.

Option Explicit  
Public Sub GetInfo()
Dim ws As Worksheet, html As HTMLDocument, s As String
Const URL As String = "https://www.stormore.net/self-storage-seattle-wa-101616#utm_source=GoogleLocal&utm_medium=WRLocal&utm_campaign=101616"

Set ws = ThisWorkbook.Worksheets("Sheet1")
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", URL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0"
    .send
    s = .responseText
    html.body.innerHTML = s

    Dim headers(), results(), listings As Object, amenities As String

    headers = Array("Size", "Description", "Amenities", "Offer1", "Offer2", "RateType", "Price")
    Set listings = html.querySelectorAll(".main li[class]")

    Dim rowCount As Long, numColumns As Long, r As Long, c As Long
    Dim icons As Object, icon As Long, amenitiesInfo(), i As Long, item As Long

    rowCount = listings.Length
    numColumns = UBound(headers) + 1

    ReDim results(1 To rowCount, 1 To numColumns)
    Dim html2 As HTMLDocument
    Set html2 = New HTMLDocument
    For item = 0 To listings.Length - 1
        r = r + 1
        html2.body.innerHTML = listings.item(item).innerHTML
        'size,description, amenities,specials offer1 offer2, rate type, price

        results(r, 1) = Trim$(html2.querySelector(".size").innerText)
        results(r, 2) = Trim$(html.querySelector(".description").innerText)
        Set icons = html2.querySelectorAll("i[title]")

        ReDim amenitiesInfo(0 To icons.Length - 1)

        For icon = 0 To icons.Length - 1
            amenitiesInfo(icon) = icons.item(icon).getAttribute("title")
        Next

        amenities = Join$(amenitiesInfo, ", ")

        results(r, 3) = amenities
        results(r, 4) = html2.querySelector(".offer1").innerText
        results(r, 5) = html2.querySelector(".offer2").innerText
        results(r, 6) = html2.querySelector(".rate-label").innerText
        results(r, 7) = html2.querySelector(".price").innerText
    Next

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

Answer 1

Я думаю, вы хотите что-то вроде следующего.

Начальная ошибка:

Я думаю, что ваша первоначальная ошибка частично связана с тем, что URL не возвращает HTML, который вы видите при использовании того же URL в браузере. Контент, который я видел, не содержал этих списков в ответе, следовательно, количество строк было 0; следовательно, ваша ошибка subscript out of range ошибка в этой строке: ReDim results(1 To rowCount, 1 To numColumns)

Итак, URL изменился на:

https://www.stormore.net/self-storage-seattle-wa-101616

Далее:

Изучив html, чтобы выяснить, как генерировать строки списков, мы замечаем, что списки представлены чисто .main li.pure-g. Дополнительный класс необходимо добавить в li, чтобы отфильтровать нежелательную информацию. Мы хотим зациклить только те строки, которые содержат интересующую информацию.

Set listings = html.querySelectorAll(".main li.pure-g")

Наконец:

При проверке html мы замечаем, что не во всех строках есть все элементы, представляющие интерес, например, offer1 и offer2, поэтому мы оборачиваем попытки доступа к некоторым элементам в On Error Resume Next, On Error GoTo 0, чтобы замаскировать ошибку, и выводим "" в этом столбце вывода.

---

VBA:

Option Explicit

Public Sub GetInfo()
    Dim ws As Worksheet, html As HTMLDocument, s As String
    Const URL As String = "https://www.stormore.net/self-storage-seattle-wa-101616"

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set html = New HTMLDocument
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        s = .responseText

        html.body.innerHTML = s

        Dim headers(), results(), listings As Object, amenities As String

        headers = Array("Size", "Description", "Amenities", "Offer1", "Offer2", "RateType", "Price")
        Set listings = html.querySelectorAll(".main li.pure-g")

        Dim rowCount As Long, numColumns As Long, r As Long, c As Long
        Dim icons As Object, icon As Long, amenitiesInfo(), i As Long, item As Long

        rowCount = listings.Length
        numColumns = UBound(headers) + 1

        ReDim results(1 To rowCount, 1 To numColumns)
        Dim html2 As HTMLDocument
        Set html2 = New HTMLDocument
        For item = 0 To listings.Length - 1
            r = r + 1
            html2.body.innerHTML = listings.item(item).innerHTML
            'size,description, amenities,specials offer1 offer2, rate type, price

            results(r, 1) = Trim$(html2.querySelector(".size").innerText)
            results(r, 2) = Trim$(html2.querySelector(".description").innerText)
            On Error Resume Next
            Set icons = html2.querySelectorAll("i[title]")
            ReDim amenitiesInfo(0 To icons.Length - 1)

            For icon = 0 To icons.Length - 1
                amenitiesInfo(icon) = icons.item(icon).getAttribute("title")
            Next

            amenities = Join$(amenitiesInfo, ", ")

            results(r, 3) = amenities

            results(r, 4) = html2.querySelector(".offer1").innerText
            results(r, 5) = html2.querySelector(".offer2").innerText
            On Error GoTo 0
            results(r, 6) = html2.querySelector(".rate-label").innerText
            results(r, 7) = html2.querySelector(".price").innerText
        Next

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