Разбор JSON в Excel - LOOP

Question

У меня есть код, который получает исторические цены акций, анализируя JSON.Мне нужно получить цену «Закрыть» на конкретную дату.Мне нужен код, чтобы прочитать дату из ячейки Excel и вставить цену, соответствующую дате.Вот пример:

https://cloud.iexapis.com/stable/stock/AAPL/chart/1m?token=pk_98e61bb72fd84b7d8b5f19c579fd0d9d

Ниже приведен мой код, но мне нужно изменить его, чтобы он мог зацикливаться, чтобы найти требуемую дату:

Sub getHistoricalData()
'Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim symbol As Variant
Dim n As Integer
Dim lastrow As Long
Dim myrequest As Variant
Dim i As Variant

Set wb = ActiveWorkbook
Set ws = Sheets("Sheet1")
ws.Activate

'Last row find
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row

Set rng = ws.Range("A3:A" & lastrow)

'Clear Prior Prices
ws.Range("k3:k" & lastrow).ClearContents

n = 3

'Get Symbols list
For Each symbol In rng
    Set myrequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    myrequest.Open "Get", "https://cloud.iexapis.com/stable/stock/" & symbol & "/chart/1m?token=pk_98e61bb72fd84b7d8b5f19c579fd0d9d" 'updated 06/15/2019
    'Debug.Print myrequest.ResponseText

    Dim Json As Object
    Set Json = JsonConverter.ParseJson(myrequest.ResponseText)

    'MsgBox (myrequest.ResponseText)
    i = Json("Close")
    ws.Range(Cells(n, 2), Cells(n, 2)) = i
    n = n + 1
Next symbol

ws.Columns("k").AutoFit
'MsgBox ("Data is downloaded.")

ws.Range("k3:k" & lastrow).HorizontalAlignment = xlGeneral
ws.Range("k3:k" & lastrow).NumberFormat = "$#,##0.00"

Application.DisplayAlerts = True
Application.ScreenUpdating = False

End Sub

Например, мне нужно извлечь цену закрытия 06/06/2019 для каждого символа акции.

Answer 1

Парсер Json был бы идеальным выбором. Тем не менее, вы можете также вывести из ответа и обработать случаи ошибок http, то есть, когда не удалось установить соединение с желаемой страницей, а также и дата не найдена. Я прочитал дату из ячейки A1. Дата отформатирована однозначно как гггг-мм-дд. Тикеры считываются в массив, который зациклен - это быстрее. Результаты сохраняются в массиве и записываются один раз на лист - также быстрее.

Option Explicit
Public Sub GetClosePrices()
    Dim lastRow As Long, url As String, ws As Worksheet, tickers(), dateString As String

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws
        dateString = Format$(.Range("A1").Value, "yyyy-mm-dd")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 3 Then
           .Range("K3:K" & lastRow).ClearContents
            tickers = Application.Transpose(.Range("A3:A" & lastRow).Value)
        Else
           Exit Sub
        End If
    End With

    Dim s As String, re As Object, p As String, r As String, prices(), i As Long
    ReDim prices(1 To UBound(tickers))

    p = """DATE_HERE"",""open"":[0-9.]+,""close"":(.*?),"   'Format must be YYYY-MM-DD
    p = Replace$(p, "DATE_HERE", dateString)
    url = "https://cloud.iexapis.com/stable/stock/TICKER_HERE/chart/1m?token=pk_98e61bb72fd84b7d8b5f19c579fd0d9d"
    Set re = CreateObject("VBScript.RegExp")

    With CreateObject("MSXML2.XMLHTTP")
        For i = LBound(tickers) To UBound(tickers)
            .Open "GET", Replace$(url, "TICKER_HERE", tickers(i)), False
            .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
            .send
            If .Status = 200 Then
                s = .responseText
                r = GetValue(re, s, p)
            Else
                r = "Failed connection"
            End If
            prices(i) = r
        s = vbNullString
        Next
    End With
    ws.Cells(3, "K").Resize(UBound(prices), 1) = Application.Transpose(prices)
End Sub

Public Function GetValue(ByVal re As Object, ByVal inputString As String, ByVal pattern As String) As String
    With re
        .Global = True
        .pattern = pattern
        If .test(inputString) Then  ' returns True if the regex pattern can be matched agaist the provided string
            GetValue = .Execute(inputString)(0).submatches(0)
        Else
            GetValue = "Not found"
        End If
    End With
End Function

Regex объяснение для примера даты ( попробовать ):

Answer 2

Ответ JSON - это массив объектов (представленных библиотекой VBA-JSON в виде коллекции словарей), поэтому вам нужно перебрать их и найти интересующий объект на основе даты:

Dim closePrice
Set Json = JsonConverter.ParseJson(myrequest.ResponseText)
For Each o in Json
    if o("date") = "2019-06-06" Then
        closePrice = o("close")
        exit for
    end if
Next o