samedi 1 juin 2019

Output pages sheet need to be on one Sheet

I have made a code but there are some issues with code. 1. All pages appear on separate sheets instead of one. 2. If 20000 to 20001 range is defined it should not give results because there is no pages with this range but in this code it is giving results, don't know from where.

Option Explicit
Public Sub GetRestuarantInfo()
    Dim s As String, re As Object, p As String, page As Long, r As String, json As Object
    Const START_PAGE As Long = 2
    Const END_PAGE As Long = 4
    Const RESULTS_PER_PAGE As Long = 30

    p = "\[{""@context"".*?\]"
    Set re = CreateObject("VBScript.RegExp")

    Application.ScreenUpdating = False

    With CreateObject("MSXML2.XMLHTTP")

        For page = START_PAGE To END_PAGE
            .Open "GET", "https://www.yellowpages.com/atlanta-ga/restaurants?page=" & page, False
            .send
            If .Status = 200 Then
                s = .responseText
                r = GetValue(re, s, p)
                If r <> "Not Found" Then
                    Set json = JsonConverter.ParseJson(r)
                    WriteOutResults page, RESULTS_PER_PAGE, json
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Public Sub WriteOutResults(ByVal page As Long, ByVal RESULTS_PER_PAGE As Long, ByVal json As Object)
    Dim sheetName As String, results(), r As Long, headers(), ws As Worksheet
    ReDim results(1 To RESULTS_PER_PAGE, 1 To 3)

    sheetName = "page" & page
    headers = Array("Name", "Website", "Tel")
    If Not WorksheetExists(sheetName) Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = sheetName
    Else
        ThisWorkbook.Worksheets(sheetName).Cells.ClearContents
    End If
    With ws
        Dim review As Object
        For Each review In json  'collection of dictionaries
            r = r + 1
            results(r, 1) = review("name")
            results(r, 2) = review("url")
            results(r, 3) = review("telephone")
        Next
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetValue(ByVal re As Object, inputString As String, ByVal pattern As String) As String
'https://regex101.com/r/M9oRON/1
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .pattern = pattern
        If .Test(inputString) Then
            GetValue = .Execute(inputString)(0)
        Else
            GetValue = "Not found"
        End If
    End With
End Function

Public Function WorksheetExists(ByVal sName As String) As Boolean  '@Rory https://stackoverflow.com/a/28473714/6241235
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Please help in resolution of issues as I am new to web scraping.




Aucun commentaire:

Enregistrer un commentaire