Проблема с отделами при импорте данных

Question

Я успешно извлекал данные из разных сетей и до сих пор добился успеха, но теперь я застрял на одном сайте.Я изменил свой код в соответствии с Интернетом, и я новичок в веб-очистке.

Вот мой код:

Option Explicit
Public Sub GetListings()
    Dim html As HTMLDocument, page As Long, html2 As HTMLDocument
    Dim results As Object, headers(), ws As Worksheet, i As Long

    Const START_PAGE As Long = 0
    Const END_PAGE As Long = 180

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = Array("Name", "Phone", "Address")
    Application.ScreenUpdating = False
    Set html = New HTMLDocument
    Set html2 = New HTMLDocument
    ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers

    With CreateObject("MSXML2.XMLHTTP")
        For page = START_PAGE To END_PAGE
            .Open "GET", "https://www.yelp.com/search?cflt=restaurants&find_loc=San%20Francisco%2C%20CA&start=" & page, False
            .send
            html.body.innerHTML = .responseText
            Set results = html.querySelectorAll(".lemon--ul__-27c0__1_cxs undefined list__373c0__2G8oH")
            Dim output(), r As Long
            ReDim output(1 To results.Length, 1 To 3)
            r = 1
            For i = 0 To results.Length - 1
                On Error Resume Next
                html2.body.innerHTML = results.Item(i).outerHTML
                output(r, 1) = html2.querySelector(".lemon--div__373c0__1mboc businessName__373c0__1fTgn border-color--default__373c0__2oFDT").innerText
                output(r, 2) = html2.querySelector(".lemon--div__373c0__1mboc display--inline-block__373c0__2de_K u-space-b1 border-color--default__373c0__2oFDT").innerText
                'output(r, 3) = html2.querySelector(".track-visit-website").href
                output(r, 3) = html2.querySelector(".lemon--div__373c0__1mboc display--inline-block__373c0__2de_K u-space-b1 border-color--default__373c0__2oFDT").innerText & " " & html2.querySelector(".lemon--div__373c0__1mboc u-space-b1 border-color--default__373c0__2oFDT").innerText
                On Error GoTo 0
                r = r + 1
            Next
            ws.Cells(GetLastRow(ws, 1) + 1, 1).Resize(UBound(output, 1), UBound(output, 2)) = output
            page = page + 30
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Проблема выделена на рисунке ниже:

Answer 1

Хотя я не уверен, что вы подразумевали под делением, я сделал предположение и написал сценарий для этой цели. Очень трудно выделить ту часть элементов, с которой вы хотите получить данные. Я едва помещаю свои коды между On Error Resume Next и On Error GoTo 0, но здесь я осмелюсь, поскольку я могу видеть то же самое в вашем сценарии. Адресный блок состоит из двух разных частей. Я справился с одним. Разделение (что я догадался) на блок адреса. Таким образом, когда вы видите, что скрипт не может найти адрес, он также не найдет разделение. Вы можете обработать блок адресов, определив условный оператор, добавив a[href] в другой .querySelector(), чтобы найти пропущенные адреса.

Sub GetInfo()
    Const URL$ = "https://www.yelp.com/search?cflt=restaurants&find_loc=San%20Francisco%2C%20CA&start="
    Dim Http As New XMLHTTP60, Html As New HTMLDocument, Htmldoc As New HTMLDocument, page&, I&

    For page = 1 To 2 ' this is where you change the last number for the pages to traverse
        With Http
            .Open "GET", URL & page * 30, False
            .send
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll("[class*='searchResult']")
            For I = 0 To .Length - 1
                Htmldoc.body.innerHTML = .item(I).outerHTML
                On Error Resume Next
                R = R + 1: Cells(R, 1) = Htmldoc.querySelector("[class*='heading--h3'] > a").innerText
                Cells(R, 2) = Htmldoc.querySelector("[class*='container'] > [class*='display--inline-block']").innerText
                Cells(R, 3) = Htmldoc.querySelector("[class*='container'] > address").innerText
                Cells(R, 4) = Htmldoc.querySelector("[class*='container'] > address").NextSibling.innerText
                On Error GoTo 0
            Next I
        End With
    Next page
End Sub

Ссылка для добавления перед запуском скрипта:

Microsoft Html Object Library
Microsoft xml, v6.0

Answer 2

Частично решена проблема

Вот модифицированный код.В некоторых случаях по-прежнему не удается получить адрес

Set results = html.getElementsByClassName("lemon--div__373c0__1mboc largerScrollablePhotos__373c0__3FEIJ arrange__373c0__UHqhV border-color--default__373c0__2oFDT")
            Debug.Print results.Length
            Dim output(), r As Long
            ReDim output(1 To results.Length, 1 To 3)
            r = 1
            For i = 0 To results.Length - 1
                'On Error Resume Next
                html2.body.innerHTML = results.Item(i).innerHTML
                output(r, 1) = html2.getElementsByClassName("lemon--a__373c0__IEZFH link__373c0__29943 link-color--blue-dark__373c0__1mhJo link-size--inherit__373c0__2JXk5")(0).innerText
                output(r, 2) = html2.getElementsByClassName("lemon--p__373c0__3Qnnj text__373c0__2pB8f text-color--normal__373c0__K_MKN text-align--right__373c0__3ARv7")(0).innerText
                output(r, 3) = html2.getElementsByClassName("lemon--p__373c0__3Qnnj text__373c0__2pB8f text-color--normal__373c0__K_MKN text-align--right__373c0__3ARv7")(1).innerText
                'On Error GoTo 0
                r = r + 1
            Next
            ws.Cells(GetLastRow(ws, 1) + 1, 1).Resize(UBound(output, 1), UBound(output, 2)) = output

, чтобы лучше запустить сценарий, не отключая обновление экрана, поскольку для вывода хотя бы одной страницы требуется немало времени.