[已解决]请高手帮忙！

fggf

格式较固定，如何用vba提取所要到工作表中。请高手帮忙，万分感谢！

最佳答案

月排行榜 / 总排行榜

雪舞子

2016-10-21 11:45

1. Sub test_XWZ()
   
2.     Dim strText As String, data As Object, bId, bList
   
3.     Dim brr(1 To 1000, 1 To 9), ar(2)
   
4.     ar(0) = Array("交标序号", "投标单位", "报价（万元）", "工期", "质量", "差值（万元）", "评标序号", "项目经理", "审查结果")
   
5.     ar(1) = Array("projname", "openDate", "bidPriceNotes")
   
6.     ar(2) = Array("comNum", "deptName", "bidDataQuote", "bidDataDays", "bidDataQa", "diffValue", "evaOrder", "mgrName", "checkResult")
   
7.     With CreateObject("MSXML2.XMLHTTP")
   
8.         .Open "POST", "http://www.qzzb.gov.cn/liveBroadcast/getLiveBidderNotList.do", False
   
9.         .setRequestHeader "Content-Type", "application/json;charset=UTF-8"
   
10.         .Send "{bidProjId:21257}"
    
11.         strText = .responsetext
    
12.     End With
    
13.     With CreateObject("msscriptcontrol.scriptcontrol")
    
14.         .Language = "JavaScript"
    
15.         .AddCode "var mydata=" & strText
    
16.         Set objJSON = .CodeObject
    
17.     End With
    
18.     For i = 0 To 2
    
19.         brr(i + 1, 1) = CallByName(objJSON.mydata.data, ar(1)(i), VbGet)
    
20.     Next
    
21.     i = i + 1
    
22.     For j = 0 To 8
    
23.         brr(i, j + 1) = ar(0)(j)
    
24.     Next
    
25.     For Each bList In objJSON.mydata.data.bidderList
    
26.         i = i + 1
    
27.         For j = 0 To 8
    
28.             brr(i, j + 1) = CallByName(bList, ar(2)(j), VbGet)
    
29.         Next
    
30.     Next
    
31.     [a2:i1000] = ""
    
32.     [a2].Resize(i, 9) = brr
    
33. End Sub
    

复制代码

如何用vba提取网页数据.rar (57.58 KB, 下载次数: 7)

2016-10-21 11:45 上传

点击文件名下载附件

跳转到最佳答案楼层

雪舞子

1. Sub test_XWZ()
   
2.     Dim strText As String, data As Object, bId, bList
   
3.     Dim brr(1 To 1000, 1 To 9), ar(2)
   
4.     ar(0) = Array("交标序号", "投标单位", "报价（万元）", "工期", "质量", "差值（万元）", "评标序号", "项目经理", "审查结果")
   
5.     ar(1) = Array("projname", "openDate", "bidPriceNotes")
   
6.     ar(2) = Array("comNum", "deptName", "bidDataQuote", "bidDataDays", "bidDataQa", "diffValue", "evaOrder", "mgrName", "checkResult")
   
7.     With CreateObject("MSXML2.XMLHTTP")
   
8.         .Open "POST", "http://www.qzzb.gov.cn/liveBroadcast/getLiveBidderNotList.do", False
   
9.         .setRequestHeader "Content-Type", "application/json;charset=UTF-8"
   
10.         .Send "{bidProjId:21257}"
    
11.         strText = .responsetext
    
12.     End With
    
13.     With CreateObject("msscriptcontrol.scriptcontrol")
    
14.         .Language = "JavaScript"
    
15.         .AddCode "var mydata=" & strText
    
16.         Set objJSON = .CodeObject
    
17.     End With
    
18.     For i = 0 To 2
    
19.         brr(i + 1, 1) = CallByName(objJSON.mydata.data, ar(1)(i), VbGet)
    
20.     Next
    
21.     i = i + 1
    
22.     For j = 0 To 8
    
23.         brr(i, j + 1) = ar(0)(j)
    
24.     Next
    
25.     For Each bList In objJSON.mydata.data.bidderList
    
26.         i = i + 1
    
27.         For j = 0 To 8
    
28.             brr(i, j + 1) = CallByName(bList, ar(2)(j), VbGet)
    
29.         Next
    
30.     Next
    
31.     [a2:i1000] = ""
    
32.     [a2].Resize(i, 9) = brr
    
33. End Sub
    

复制代码

如何用vba提取网页数据.rar (57.58 KB, 下载次数: 7)

2016-10-21 11:45 上传

点击文件名下载附件

fggf

雪舞子 发表于 2016-10-21 11:45

您好，可以麻烦您再帮我看下吗，现在网址有稍微改动（多加 了几个字母），造成提取数据失败了，不知要怎么改动呢？
这是之前的网址:

现在的网址是：

（说明：isHistory的等号后面只有0和1两种数字，0表示当天日期开标的，1表示今天之前已开过标的。要让这个isHistory的数字自动采用L1单元格上的数字，而bidProjId等号后面的数字则自动采用M1单元格上的数字）