Option Explicit
Const NF As String = "NOT FOUND"
Option Base 1
Dim MyRequest As MSXML2.XMLHTTP60
Dim r1$, r2$, r3$, r4$, r5$, r6$, r7$, r8$
Dim NextURL
Dim ItemsCount&
Sub STk()
    r1 = Chr(34) '"
    r2 = Chr(58) ':
    r3 = Chr(123) '{
    r4 = Chr(125) '}
    r5 = Chr(91) '[
    r6 = Chr(93) ']
    r7 = Chr(33) 'space
    r8 = Chr(44) ',
End Sub
Sub StartPars()
    Const MassLC As Integer = 30
    Const StURL As String = "https://5ka.ru/api/special_offers/?records_per_page=15&page=1"
    Dim MyRequest
    Dim mass()
    Dim x&, y&, z&, mC&, rC&
    Dim tmpCol As Collection
    Dim tmpCol2 As Collection
    Dim VAL As Variant
    Dim FirstLoop As Boolean
    Dim isDate As Boolean
        Set MyRequest = New MSXML2.XMLHTTP60
        STk
        NextURL = StURL
        If Not IsEmpty([A1]) Then Range("A1").Resize(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column).ClearContents
        rC = 1
        FirstLoop = True
        isDate = False
        With MyRequest
            Do
                .Open "GET", NextURL
                .SetRequestHeader "Host", "5ka.ru"
                .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/62.0.3202.94 Safari/537.36"
                .SetRequestHeader "X-Requested-With", "XMLHttpRequest"
                .send
                    Set tmpCol = GetParsCol(.ResponseText)
                    If FirstLoop Then ReDim mass(ItemsCount + 10, MassLC): FirstLoop = False
                        For x = 1 To tmpCol.Count
                            rC = rC + 1
                            Set tmpCol2 = ReplVal(tmpCol.Item(x))
                                For y = 1 To tmpCol2.Count
                                    mC = 0
                                        For Each VAL In Split(tmpCol2.Item(y), ":")
                                            mC = mC + 1
                                                Select Case mC
                                                    Case 1
                                                        For z = 1 To MassLC
                                                            isDate = Not IsError(Application.Search("date", VAL))
                                                            If mass(1, z) = VAL Then Exit For
                                                            If IsEmpty(mass(1, z)) Then mass(1, z) = VAL: Exit For
                                                        Next
                                                    Case 2: If isDate Then mass(rC, z) = DateFromUnix(VAL) Else mass(rC, z) = VAL
                                                End Select
                                        Next
                                Next
                        Next
            Loop While NextURL <> "null"
            Range("A1").Resize(UBound(mass), MassLC) = mass
        End With
End Sub
Function ReplVal(vStr As String) As Collection
    Dim VAL
    Dim kk As New Collection
    Dim kk2 As New Collection
    Dim rVal$
    Dim KeyW
    Dim mC%
    Dim x&, y&, z&
    Dim ANC As Boolean
        kk2.Add Chr(34) '"
        kk2.Add Chr(123) '{
        kk2.Add Chr(125) '}
        kk2.Add Chr(91) '[
        kk2.Add Chr(93) ']
    On Error Resume Next
            For Each VAL In Split(vStr, r8 & r1)
                rVal = VAL
                For x = 1 To kk2.Count: rVal = Replace(rVal, kk2.Item(x), ""): Next
                kk.Add rVal
            Next
            Set kk2 = Nothing
                kk2.Add "image_small"
                kk2.Add "image_big"
                kk2.Add "date_start"
                kk2.Add "date_end"
                kk2.Add "special_price"
                kk2.Add "regular_price"
                kk2.Add "discount_percent"
                kk2.Add "id"
                kk2.Add "name"
            z = kk.Count
                For x = 1 To z
                    ANC = False
                    mC = 0
                        For Each VAL In Split(kk.Item(x), r2)
                            mC = mC + 1
                                For y = 1 To kk2.Count
                                    If mC = 1 Then
                                        If VAL = kk2.Item(y) Then ANC = True: Exit For
                                    End If
                                Next
                            If mC = 1 And Not ANC Then kk.Remove (x): x = x - 1: z = z - 1: Exit For
                            If mC = 1 And ANC Then Exit For
                        Next
                Next
            Set ReplVal = kk
End Function
Function DateFromUnix(s As Variant) As Date
    Dim d As Double
        If (Len(s) = 13) Then
            d = CDbl(Left(s, 10)) 'javaScript Time
            If Int(Mid(s, 11, 3) >= 500) Then d = d + 1 'may need to round for milliseconds
        ElseIf (Len(s) = 10) Then
            d = CDbl(s) 'unix Time
        Else
            DateFromUnix = CVErr(xlErrValue) 'wtf time
            Exit Function
        End If
        DateFromUnix = DateAdd("s", d, DateSerial(1970, 1, 1))
End Function
Function GetParsCol(ParseResponse As String) As Collection
    Dim d$
    Dim st&, et&, cc&, mC&
    Dim tmpCol As New Collection
    Dim VAL, VAL2
    Dim FirstLoop As Boolean
    Dim isFnd As Boolean
        d = r3 & r1 & "shopitem_categories" & r1 & r2 & r5 '& r6'& r8'{"shopitem_categories":[],
        FirstLoop = True
        isFnd = False
    On Error GoTo errH
            Do
                st = Application.WorksheetFunction.Search(d, ParseResponse, 1)
                    If FirstLoop Then
                        FirstLoop = False
                            For Each VAL In Split(Left(ParseResponse, st), ",")
                                mC = 0
                                    For Each VAL2 In Split(Left(VAL, st), r1 & r2)
                                        mC = mC + 1
                                            Select Case VAL2
                                                Case r3 & r1 & "count": cc = 1
                                                Case r1 & "next": cc = 2
                                            End Select
                                        If mC = 2 Then
                                            Select Case cc
                                                Case 1: ItemsCount = CDbl(Replace(VAL2, r1, ""))
                                                Case 2: NextURL = Replace(VAL2, r1, ""): isFnd = True: Exit For
                                            End Select
                                        End If
                                    Next
                                If isFnd Then Exit For
                            Next
                    End If
                ParseResponse = Right(ParseResponse, Len(ParseResponse) - st - Len(d) + 1)
                et = Application.WorksheetFunction.Search(d, ParseResponse, 1)
                tmpCol.Add Left(ParseResponse, et - 2)
            Loop While st > 0
        Exit Function
errH:
        Set GetParsCol = tmpCol
End Function