网抓数据无法正常运行，求老师帮忙改正，谢谢！

fggf

网抓数据问题.rar (7.59 KB, 下载次数: 8)

2018-7-11 10:36 上传

点击文件名下载附件

自己搜索套用的代码如下，运行提示错误，请老师帮忙改正下，万分感谢！
'http://www.qzzb.gov.cn/default/calendarDetail.do?time=2018-7-12&centerId=0

Sub main()
Application.ScreenUpdating = False
Range("A3:K25").ClearContents
Dim url, html
url = "http://www.qzzb.gov.cn/default/calendarDetail.do?time=2018-7-12&centerId=0"
Set html = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
   .Open "get", url, False
   .Send
     html.body.innerhtml = .ResponseText
     Set tb = html.all.tags("table")(1).Rows
     For i = 0 To tb.Length - 1
       For j = 0 To tb(i).Cells.Length - 1
       Cells(i + 3, j + 1) = tb(i).Cells(j).innertext
       Next
     Next
End With
Application.ScreenUpdating = True
End Sub

fggf

谁帮忙看看下啊

fggf

为什么提取无法得到数据呢

Kaohsing

网址不对                          

fxl447098457

post不是get.你要提交正文。


格式是json，没有什么table.不要乱套代码。。。

fggf

fxl447098457 发表于 2018-7-13 11:06
post不是get.你要提交正文。

谢谢，你直接帮忙改下吗

fxl447098457

fggf

fxl447098457 发表于 2018-7-13 11:33

如果要直接显示为表格（从A3行开始），要怎么转换呢，再打扰下，谢谢

fxl447098457

fggf 发表于 2018-7-13 18:03
如果要直接显示为表格（从A3行开始），要怎么转换呢，再打扰下，谢谢

Sub main()
ActiveSheet.UsedRange.ClearContents
url = "http://www.qzzb.gov.cn/default/getCalDetail.do"
With CreateObject("msxml2.xmlhttp")
   .Open "POST", url, False
   .send ("{openDate:'2018-7-10',centerId:0}")
json = .responsetext
End With
js = "j=" & json & ";js=j['data'];var r,k,row=col=1,d={},title=['centerName','projName','ownerDeptName'," _
& "'agentDeptName','linkMan','linkTel','openDate','tradeplatName'];for(r in js){row++;for(k in title)" _
& "{if(!d[title[k]]){d[title[k]]=col++;rng(1,d[title[k]])=title[k];}rng(row,d[title[k]])=js[r][title[k]];}}"
With CreateObject("scriptcontrol")
    .Language = "jscript"
    .addobject "rng", Cells(1, 1)
    .eval (js)
End With
End Sub