получить данные веб-страницы через имя класса

Question

Мне нужно получить даты и температуру с веб-сайта о погоде и записать их в ячейки, но я получаю ошибку object variable or with block variable not set.

Я пытался получить данные из Интернета в Excel, но я думаю, что веб-сайтзащищенный или что-то еще, потому что я продолжаю получать страницу "на обслуживании" при попытке загрузить страницу из Excel.Я получил приведенные ниже коды из учебника, но не могу заставить его работать.

Sub record()

    Dim request As Object
    Dim response As String
    Dim html As New HTMLDocument
    Dim websie As String
    Dim temps As Variant

    'provide link
    'website = "https://finance.yahoo.com/quote/EURUSD=X?p=EURUSD=X"
    website = "https://www.accuweather.com/en/us/chicago/60608/september-weather/348308"

    'create the object that will make the webpage request
    Set request = CreateObject("MSXML2.XMLHTTP")

    'go to the link
    request.Open "GET", website, False

    'send request for webpage
    request.send

    'get web response data to variable
    response = StrConv(request.responseBody, vbUnicode)

    'put webpage to an html object
    html.body.innerHTML = response

    'get temperature from specified element
    'temps = html.getElementsByClassName("Trsdu(0.3s) Fw(b) Fz(36px) Mb(-4px) D(ib)")(0).innerText
    temps = html.getElementsByClassName("high")(0).innerText


     Sheets("record").Range("A1") = temps

End Sub

Примеры строк с сайта:

<a class="monthly-daypanel is-past">
   <div class="date">2</div>
   <div class="icon-container"...</div>
   <div class="temp">
      <div class="high">83</div>
      <div class="low">83</div>
   </div>
</a>

Я хочу получить date,high и low.

Answer 1

Вам нужен заголовок User-Agent.Я также извлек бы строку json из одного из тегов сценария (для этого я использую регулярное выражение) и использовал ее в качестве источника.Я добавляю сравнение дат, чтобы понять, является ли это прогнозом или фактическим значением.Я считываю строку json в объект json, используя библиотеку json, и зацикливаю результирующую коллекцию, хранящую элементы, представляющие интерес, в массиве для более быстрой записи в лист в конце.

Библиотека json:

Я использую jsonconverter.bas.Загрузите необработанный код с здесь и добавьте в стандартный модуль jsonConverter.Затем вам нужно перейти VBE> Инструменты> Ссылки> Добавить ссылку на Microsoft Scripting Runtime.

Option Explicit

Public Sub GetWeatherListings()

    Dim s As String, re As Object, ws As Worksheet

    Set re = CreateObject("vbscript.regexp")
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.accuweather.com/en/us/chicago/60608/september-weather/348308", False
       ' .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        s = .responsetext
    End With

    Dim results(), r As Long, jsonSource As String, json As Object, item As Object

    jsonSource = GetString(re, s, "dailyForecast = (.*?\])")

    If jsonSource = "No match" Then Exit Sub

    Set json = JsonConverter.ParseJson(jsonSource)

    ReDim results(1 To json.count, 1 To 4) 'date, datetime,  day > dActual, night > dActual

    Dim dateTime() As String, datePart As String, forecast As Boolean

    For Each item In json
        r = r + 1
        dateTime = Split(item("dateTime"), "T")
        datePart = dateTime(LBound(dateTime))
        forecast = CDate(datePart) >= Date
        results(r, 1) = datePart
        results(r, 2) = item("dateTime")
        results(r, 3) = IIf(forecast, item("day")("dTemp"), item("day")("dActual"))
        results(r, 4) = IIf(forecast, item("night")("dTemp"), item("night")("dActual"))
    Next

    Dim headers()

    headers = Array("Date", "DateTime", "Day temp", "Night temp")

    With ws
        .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 GetString(ByVal re As Object, ByVal inputString As String, ByVal pattern As String) As String
    Dim matches As Object

    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .pattern = pattern
        If .Test(inputString) Then
            Set matches = .Execute(inputString)
            GetString = matches(0).SubMatches(0)
            Exit Function
        End If
    End With
    GetString = "No match"
End Function

---

Пример конца вывода: