Страницы объединяются в конец URL.Я бы использовал запросы на выдачу xhr в цикле по заданному диапазону страниц и выводил бы json, который содержит необходимую информацию (он находится в одном из тегов скрипта).Этот метод очень быстрый и более чем компенсирует использование регулярных выражений.Я также использую объекты, где это возможно.
Я использую jsonconverter.bas для обработки json и анализа необходимой информации (в json гораздо больше информации, включая обзоры).После загрузки .bas и добавления в модуль JsonConverter в вашем проекте вам нужно перейти в VBE> Инструменты> Ссылки> Добавить ссылку в Microsoft Scripting Runtime.
Вспомогательные функции используются для проверки того, должна ли страница записываться.уже существует или требует создания, а также для записи результатов json в массив и выгрузки массива за один переход к листу (повышение эффективности).Структура оставлена, поэтому легко получить извлеченную информацию, если требуется дополнительная информация, например, обзор.
Может потребоваться некоторая работа по обеспечению работ для страниц, которые не существуют.Я просто использовал код ответа в настоящее время, чтобы отфильтровать их.
ПРИМЕЧАНИЯ:
В качестве проверки работоспособности я бы использовал InternetExplorer для перехода на страницу1 и извлеките общее количество результатов.Я бы разделил это по результатам на страницу (в настоящее время 30), чтобы рассчитать общее количество страниц.Это даст мне значения lbound и ubound (min и max для возможных страниц).Затем переключитесь на xmlhttp для фактического получения.См. Дополнительную вспомогательную функцию в конце.
Код:
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
Вспомогательная функция для возврата количества страниц
'VBE > Tools > References: Microsoft Internet Controls
Public Function GetNumberOfPages(ByVal RESULTS_PER_PAGE As Long) As Variant
Dim ie As Object, totalResults As Long
On Error GoTo errhand
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = False
.Navigate2 "https://www.yellowpages.com/atlanta-ga/restaurants?page=1"
While .Busy Or .readyState < 4: DoEvents: Wend
With .document
totalResults = Replace$(Replace$(.querySelector(".pagination p").innerText, "We found", vbNullString), "results", vbNullString)
GetNumberOfPages = totalResults / RESULTS_PER_PAGE
ie.Quit
Exit Function
End With
End With
errhand:
If Err.Number <> 0 Then
GetNumberOfPages = CVErr(xlErrNA)
End If
End Function
Regex объяснение:
Попробуйте здесь .
