mardi 4 juin 2019

Subscript out of range error during webscrapping

Subscript out of range error in line

results(r, 4) = review("streetAddress")

during webscrapping; I am importing fields from websites and data accordingly, please guide me.

Sheet A1 = https://www.yellowpages.com/atlanta-ga/restaurants?page=

 Option Explicit 

Public Sub GetRestuarantInfo()

    Dim s As String, re As Object, p As String, page As Long, r As String, json As Object 'Variable Definations
    Const START_PAGE As Long = 2
    Const END_PAGE As Long = 4
    Const RESULTS_PER_PAGE As Long = 40

    p = "\[{""@context"".*?\]"
    Set re = CreateObject("VBScript.RegExp")
    Application.ScreenUpdating = False            
    With CreateObject("MSXML2.XMLHTTP")    
    For page = START_PAGE To END_PAGE ' Run for loop for defined Page numbers
            .Open "GET", Sheet1.Range("A1") & 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 ' This module is just to write results pagewise which is not needed in your case
    headers = Array("Name", "Website", "Tel", "Address") 'Defination of headers
    If Not WorksheetExists(sheetName) Then ' Creation of sheets
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = sheetName
    Else
        ThisWorkbook.Worksheets(sheetName).ClearContents
    End If
    With ws
        Dim review As Object
        For Each review In json ' Bringing results from Json to excel sheet
            r = r + 1
            results(r, 1) = review("name") 'write results of name field
            results(r, 2) = review("url") 'write results of url field
            results(r, 3) = review("telephone") 'write results of telephone field
             results(r, 4) = review("streetAddress") 'write results of telephone field
        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
    With re
        .Global = True 
        .MultiLine = True  

        .IgnoreCase = False 'Use case-insensitive matching.
        .pattern = pattern 'The pattern (written in Regex) which you want to match against (e.g. “(.*)”)

        'Test (string) – returns True if the pattern can be matched agaist the provided string
         'Web Link: https://analystcave.com/excel-regex-tutorial/
        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
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)") 
End Function

I keep getting subscript out of range for the following code, I'm new to VBA so would greatly appreciate your help.




Aucun commentaire:

Enregistrer un commentaire