[已解决]如何将网页里多页的数据导入工作表里

zhusong19989

亲
有一个网站，“https:（我没有办法发链接，双//杠省去）gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1”，该网页下有64页，怎么才能将这64页的数据导入工作中呀。
跪求了，我从网上下载了一堆代码也没有弄好
好心的大虾，帮个忙吧。

最佳答案

月排行榜 / 总排行榜

雪舞子

2015-5-12 18:27

这个没什么难度，做个全部页码的吧，
数据已经全部抓取完，楼主可以直接拿去用。

1. Sub test()
   
2.     Dim HTML, tb, i&, j&, x&, n&, s$
   
3.     [a2:d9999] = ""
   
4.     Set HTML = CreateObject("htmlfile")
   
5.     With CreateObject("msxml2.xmlhttp")
   
6.         For x = 0 To 63
   
7.             .Open "get", "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & 30 * x, False
   
8.             .Send
   
9.             Application.Wait (Now + TimeValue("00:00:02"))
   
10.             HTML.body.innerhtml = .responsetext
    
11.             Set tb = HTML.ALL.tags("table")(0).Rows
    
12.             For i = 1 To tb.Length - 1
    
13.                 n = n + 1
    
14.                 For j = 0 To tb(i).Cells.Length - 1
    
15.                     Cells(n + 1, j + 1) = tb(i).Cells(j).innertext
    
16.                 Next
    
17.             Next
    
18.         Next
    
19.     End With
    
20.     MsgBox "获取完毕!"
    
21. End Sub

复制代码

抓数据.rar (74.03 KB, 下载次数: 903)

2015-5-12 18:26 上传

点击文件名下载附件

跳转到最佳答案楼层

Excel学徒123

1. Declare Function GetTickCount Lib "kernel32" () As Long
   
2. 
   
3. '‘http://117.21.249.37:9090/yzcg/jxyycg/search/bidCatalog.shtml?dypn=1
   
4.     Sub tttt()
   
5.         Dim HTML, URL, K, X, No
   
6.         Cells.Clear
   
7.         Application.ScreenUpdating = False
   
8.         Application.Calculation = xlCalculationManual
   
9.         Set HTML = CreateObject("htmlfile")
   
10.         K = 1
    
11.         No = 64    '总页数
    
12.         
    
13.         ParShow.Show 0    '进度条窗口显示
    
14.         With CreateObject("msxml2.xmlhttp")
    
15.         For X = 0 To No
    
16.         
    
17.         URL = "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & X
    
18.         
    
19.             .Open "get", URL, False
    
20.             .Send
    
21.             DelayTime (2000)      '延时，网速不好改大
    
22.             HTML.body.innerhtml = .responsetext
    
23.             Set tb = HTML.ALL.tags("tbody")(0)
    
24.             For I = 1 To tb.Rows.Length - 1
    
25.                 For j = 0 To tb.Rows.Item(I).Cells.Length - 1
    
26.                     Cells(I + K, j + 1) = tb.Rows(I).Cells(j).innertext
    
27.                 Next
    
28.             Next
    
29. 
    
30.         K = K + tb.Rows.Length - 1
    
31.         Set tb = Nothing
    
32.         ParShow.LblNote.Caption = "正在抓取第" & X & "页！！"
    
33.         ParShow.lblProgress.Width = Int((X / No) * ParShow.lblBack.Width) '标签宽度
    
34.         ParShow.lblPercent.Caption = Format(Int((X / No) * 100), "0") & "%" '完成百分比
    
35.         'ParShow.Repaint                                             '窗体重绘
    
36.         DoEvents
    
37.         
    
38.         Next X
    
39.         Application.Calculation = xlCalculationAutomatic
    
40.         Application.ScreenUpdating = True
    
41. 
    
42.         Set tb = Nothing
    
43.         Unload ParShow
    
44.         MsgBox "数据抓取完成！"
    
45.          End With
    
46.     End Sub
    
47. 
    
48. Sub DelayTime(DTime As Long)        '延时
    
49. 
    
50.     SaveTime = GetTickCount
    
51.     While GetTickCount < SaveTime + DTime '等待1S
    
52.         DoEvents
    
53.     Wend
    
54. End Sub
    

复制代码

下载我的附件吧，有进度条，直接复制代码要报错，具体结果 你检查下{:02:}

zhusong19989

先谢谢，再试试，再送分！

roych

1. Sub test()
   
2. Dim ie As New InternetExplorer
   
3. Dim i As Long
   
4. Dim doc As HTMLDocument
   
5. Dim tb As HTMLTable
   
6. 
   
7. For i = 0 To 1
   
8. ie.navigate "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & i * 30
   
9.     Do Until ie.readyState = READYSTATE_COMPLETE
   
10.         DoEvents
    
11.     Loop
    
12. 
    
13.     Set doc = ie.document
    
14.     Sheet1.Range("A1").Offset(i * 30, 0).Select
    
15. 
    
16.     Set tb = doc.getElementById("YKTabCon2_10")
    
17.         For j = 1 To 30
    
18.             For k = 1 To 4
    
19.                 Sheet1.Cells(j, k) = tb.Cells((j - 1) * 4 + k - 1).innerText
    
20.             Next
    
21.         Next
    
22. 
    
23. Next
    
24. End Sub
    

复制代码

还有点小问题，应该加一个延时的时间，等加载完毕后再执行。没时间弄了，下班先。
测试.rar (8.18 KB, 下载次数: 126)

2015-5-12 17:59 上传

点击文件名下载附件

zhusong19989

Excel学徒123 发表于 2015-5-12 17:41
下载我的附件吧，有进度条，直接复制代码要报错，具体结果 你检查下

太棒了，太棒了！
{:1112:}

我这个网址是从“https:（省去双//）gaokao.chsi.com.cn/zzbm/mdgs/”里来的

有办法一次把这个页面的所有高校的都导入工作表吗？

哈哈，我是得寸进尺呀。

roych

zhusong19989 发表于 2015-5-12 18:05
太棒了，太棒了！

那些高校代码参数必须获知才能处理的。

zhusong19989

roych 发表于 2015-5-12 17:59
还有点小问题，应该加一个延时的时间，等加载完毕后再执行。没时间弄了，下班先。

导出的数据不全，漏的多，重复的多，不知道问题出在哪儿了？

zhusong19989

roych 发表于 2015-5-12 18:08
那些高校代码参数必须获知才能处理的。

好的，我一个一个弄吧，这样快多了。

我是否只需要改动网址及页数即可吧。

雪舞子

这个没什么难度，做个全部页码的吧，
数据已经全部抓取完，楼主可以直接拿去用。

1. Sub test()
   
2.     Dim HTML, tb, i&, j&, x&, n&, s$
   
3.     [a2:d9999] = ""
   
4.     Set HTML = CreateObject("htmlfile")
   
5.     With CreateObject("msxml2.xmlhttp")
   
6.         For x = 0 To 63
   
7.             .Open "get", "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & 30 * x, False
   
8.             .Send
   
9.             Application.Wait (Now + TimeValue("00:00:02"))
   
10.             HTML.body.innerhtml = .responsetext
    
11.             Set tb = HTML.ALL.tags("table")(0).Rows
    
12.             For i = 1 To tb.Length - 1
    
13.                 n = n + 1
    
14.                 For j = 0 To tb(i).Cells.Length - 1
    
15.                     Cells(n + 1, j + 1) = tb(i).Cells(j).innertext
    
16.                 Next
    
17.             Next
    
18.         Next
    
19.     End With
    
20.     MsgBox "获取完毕!"
    
21. End Sub

复制代码

抓数据.rar (74.03 KB, 下载次数: 903)

2015-5-12 18:26 上传

点击文件名下载附件

Excel学徒123

雪舞子 发表于 2015-5-12 18:27
这个没什么难度，做个全部页码的吧，
数据已经全部抓取完，楼主可以直接拿去用。

我也是改之前一个写好的。。。。