Ошибка времени выполнения 424: требуется объект - извлечение данных с помощью ссылки API - PullRequest
Новая
       6

Ошибка времени выполнения 424: требуется объект - извлечение данных с помощью ссылки API

1 голос
/ 18 июня 2020

Я работаю над кодом VBA для извлечения данных с веб-сайта с помощью ссылки API.

Я пытаюсь использовать регулярное выражение для s coop из части обменного курса для usd_sgd и jpy_sgd_100 в том же листе в ячейках B2 и C2.

Я пытаюсь использовать оператор if else then для двух разных шаблонов "usd_sgd" и "jpy_sgd_100".

Когда я запускаю код, он выдает ошибку времени выполнения:

«Требуется объект ошибки времени выполнения 424»

в строке: 

For Each match In matches

Я хочу извлечь данные обменного курса для «usd_sgd» и «jpy_sgd_100» из указанной ссылки API в тот же рабочий лист в ячейках B2 и C2. Как мне исправить текущую ошибку и добиться этого результата, пожалуйста?

Код: 

Public Sub ExchangeRate()
    Dim results(), matches As Object, s As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://eservices.mas.gov.sg/api/action/datastore/search.json?resource_id=5aa64bc2-d234-43f3-892e-2f587a220f74&fields=end_of_week,usd_sgd,jpy_sgd_100&limit=1&sort=end_of_week%20desc", False
        .send
        s = .responseText
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = False

        If .Pattern = "usd_sgd"":""(.*?)""" Then
           .MultiLine = True
           Set matches = .Execute(s)
           ReDim results(1 To matches.Count)

         ElseIf .Pattern = "jpy_sgd_100"":""(.*?)""" Then
            .MultiLine = True
            Set matches = .Execute(s)
            ReDim results(1 To matches.Count)
         End If

   End With
   Dim match As Variant, r As Long
   For Each match In matches
       r = r + 1
       results(r) = match.submatches(0)
   Next
   With ThisWorkbook.Worksheets("Sheet1")
       .Cells(2, 2).Resize(UBound(results), 1) = Application.Transpose(results)
       .Cells(2, 3).Resize(UBound(results), 1) = Application.Transpose(results)
   End With
End Sub

1 Ответ

1 голос
/ 18 июня 2020

Вы никогда не устанавливаете .Pattern, поэтому вы никогда не устанавливаете .Execute(s) и, следовательно, никогда не устанавливаете matches ни на что иное, кроме Nothing. Установите .pattern на требуемый образец.

Перезапись может выглядеть так: 

Public Sub ExchangeRate()
    Dim results(), s As String

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://eservices.mas.gov.sg/api/action/datastore/search.json?resource_id=5aa64bc2-d234-43f3-892e-2f587a220f74&fields=end_of_week,usd_sgd,jpy_sgd_100&limit=1&sort=end_of_week%20desc", False
        .send
        s = .responseText
    End With

    Dim pattern As Variant, patterns(), i As Long

    patterns = Array("""usd_sgd"":""(.*?)""", """jpy_sgd_100"":""(.*?)""")

    ReDim results(1 To UBound(patterns) + 1)

    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = False
        .MultiLine = True

        For i = LBound(patterns) To UBound(patterns)

            .pattern = patterns(i)

            Set matches = .Execute(s)

            If matches.Count > 0 Then results(i + 1) = matches(0).Submatches(0)
        Next

    End With

    With ThisWorkbook.Worksheets("Sheet1")
        .Cells(2, 2).Resize(UBound(results), 1) = Application.Transpose(results)
    End With

End Sub
...