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