Внутренняя петля дизайн для веб-скрепинга

Question

Я хочу импортировать данные ресторана, такие как название ресторана, номер телефона, веб-сайт и адрес, чтобы преуспеть, но, к сожалению, я получаю спонсированные результаты, а также не получаю веб-сайт и полный адрес, как на внутренней странице, когда мы нажимаем на отель название. Я с некоторой помощью на платформах создал код, используя, но это не помогает. Пожалуйста, исправьте проблему в моем коде. Сайт: https://www.yelp.com/searchcflt=restaurants&find_loc=San%20Francisco%2C%20CA&start=

Вот мой код:

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 = 0 To 1 ' 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
               'Inner loop creation
                Cells(r, 5) = Htmldoc.querySelector("[class*='container'] > website").href ' Extract from window after clicking on hotel name
                Cells(r, 6) = Htmldoc.querySelector("[class*='container'] > fulladdress").innerText ' Extract from window after clicking on hotel name
                On Error GoTo 0
            Next I
        End With
    Next page
End Sub

Answer 1

Вы можете использовать бесплатный API для получения 50 лучших результатов из конечной точки business_search . Передайте параметр сортировки в строке запроса, чтобы получить самый высокий рейтинг.

Используйте обработчик json, например jsonconverter.bas , для обработки ответа. После установки кода по этой ссылке в стандартный модуль JsonConverter перейдите в раздел VBE> Инструменты> Ссылки> Добавить ссылку на Microsoft Scripting Runtime.

Инструкции API здесь . Вам необходимо настроить тестовое приложение , для которого требуется некоторая базовая информация о пользователе, и подтвердить свою электронную почту. Затем вы получите ключ API для аутентификации , который передается в заголовке авторизации, как показано ниже.

Возвращается другая информация, которую вы можете проанализировать, если хотите.

---

Option Explicit

Public Sub GetTopRestuarants()
    Dim json As Object, headers(), r As Long, c As Long
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://api.yelp.com/v3/businesses/search?term=restuarant&location=san-francisco&limit=50&sort_by=rating", False
        .setRequestHeader "Authorization", "Bearer yourAPIkey"
        .send
        Set json = JsonConverter.ParseJson(.responseText)("businesses")
        headers = Array("Restaurant name", "phone", "website", "address")
        Dim results(), item As Object
        ReDim results(1 To json.Count, 1 To UBound(headers) + 1)
        For Each item In json
            r = r + 1
            results(r, 1) = item("name")
            results(r, 2) = item("phone")
            results(r, 3) = item("url")
            Dim subItem As Variant, address As String
            address = vbNullString
            For Each subItem In item("location")("display_address")
                address = address & Chr$(32) & subItem
            Next
            results(r, 4) = Trim$(address)
        Next
    End With
    With ActiveSheet
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Пример вернул 20 из 50:

---

Предостережение emptor

Обратите внимание, что указание sort_by - это предложение (не строго соблюдаемое) для поиска Yelp, который рассматривает несколько входных параметров для получения наиболее релевантных результатов. Например, сортировка рейтинга не строго сортируется по значению рейтинга, но по скорректированному значению рейтинга, которое учитывает количество оценок, аналогично байесовскому среднему. Это сделано для того, чтобы предотвратить искажение результатов для предприятий с помощью одного обзора.

Answer 2

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

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

    [A1:D1] = [{"Name","Phone","Address","Website"}]

    For page = 1 To 3   'this is where you change the last number for this script to traverse
        With Http
            .Open "GET", URL & page * 30, False
            .setRequestHeader "User-Agent", "Mozilla/5.0"
            .send
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll("[class*='searchResult'] [class*='heading--h3'] > a")
            For I = 0 To .Length - 1
                If Not InStr(.item(I).getAttribute("href"), "/adredir?") > 0 Then
                    oTitle = .item(I).innerText
                    newUrl = Replace(.item(I).getAttribute("href"), "about:", base)
                    With Http
                        .Open "GET", newUrl, False
                        .setRequestHeader "User-Agent", "Mozilla/5.0"
                        .send
                        Htmldoc.body.innerHTML = .responseText
                    End With

                    R = R + 1: Cells(R + 1, 1) = oTitle

                    Set oPhone = Htmldoc.querySelector(".biz-phone")
                    If Not oPhone Is Nothing Then
                        Cells(R + 1, 2) = oPhone.innerText
                    End If

                    Set oAddress = Htmldoc.querySelector(".map-box-address")
                    If Not oAddress Is Nothing Then
                        Cells(R + 1, 3) = WorksheetFunction.Clean(oAddress.innerText)
                    End If

                    Set oWeb = Htmldoc.querySelector(".biz-website > a")
                    If Not oWeb Is Nothing Then
                        Cells(R + 1, 4) = oWeb.innerText
                    End If
                End If
            Next I
        End With
    Next page
End Sub

Кстати, реклама была удалена.