EXCEL VBA抓取网页JSON数据并解析

码猩2024-01-28 20:03

EXCEL VBA抓取网页JSON数据并解析

链接地址：

https://api.api68.com/CQShiCai/getBaseCQShiCaiList.do?lotCode=10036\&date=2024-01-26

python 复制代码

Sub test()
On Error Resume Next
Sheet.Select
Sheet1.Cells.ClearContents
[a1:g1] = Split("preDrawIssue|preDrawTime|preDrawCode 1|preDrawCode 2|preDrawCode 3|preDrawCode 4|preDrawCode 5", "|")
    Dim t As Object


    Set t = CreateObject("ScriptControl")
    t.Language = "JScript"

    sj = Format(Now, "yyyy-mm-dd")
   
  
    Dim xmlhttp As Object
  
    Set xmlhttp = CreateObject("winhttp.winhttprequest.5.1")
    With xmlhttp
    
    .Open "GET", "https://api.api68.com/CQShiCai/getBaseCQShiCaiList.do?lotCode=10036&date=" & sj, False
    .SetRequestHeader "Host", "api.api68.com"
    .SetRequestHeader "Connection", "keep-alive"
    
   
    .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/69.0.3947.100 Safari/537.36"
                                 
    .Send
    strtext = .responseText
  
        Set y = t.eval("eval(" & strtext & ")")
    End With
  
  For i = 0 To 5000
   If CallByName(CallByName(CallByName(CallByName(y, "result", VbGet), "data", VbGet), i, VbGet), "preDrawIssue", VbGet) = Empty Then Exit Sub
  Cells(2 + i, 1) = CallByName(CallByName(CallByName(CallByName(y, "result", VbGet), "data", VbGet), i, VbGet), "preDrawIssue", VbGet)
  Cells(2 + i, 2) = CallByName(CallByName(CallByName(CallByName(y, "result", VbGet), "data", VbGet), i, VbGet), "preDrawTime", VbGet)
  arr = Split(CallByName(CallByName(CallByName(CallByName(y, "result", VbGet), "data", VbGet), i, VbGet), "preDrawCode", VbGet), ",")
   Cells(2 + i, 3) = arr(0)
 Cells(2 + i, 4) = arr(1)
Cells(2 + i, 5) = arr(2)
Cells(2 + i, 6) = arr(3)
Cells(2 + i, 7) = arr(4)
  DoEvents
 

Next
End Sub