[已完美解决]]提取所有网页数据，共64页

LMY123

提取所有页的数据.rar (11.96 KB, 下载次数: 118)

2015-10-3 19:31 上传

点击文件名下载附件

网页一共64页
分别是
https://gaokao.chsi.com.cn/zzbm/ ... 733931&lx=1&start=0
https://gaokao.chsi.com.cn/zzbm/ ... 33931&lx=1&start=30
---------------------------------------------
https://gaokao.chsi.com.cn/zzbm/ ... 931&lx=1&start=1890
网页最后那个数字的步长值是30

LMY123

'能否把我把下面几句代码改变为循环呢？谢谢
Sub 提取网页第1页()
  With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=0"
        Do Until .ReadyState = 4
            DoEvents
        Loop
       Set r = .Document.All.tags("td")
       For I = 0 To r.Length - 1
       Cells(I + 1, 1) = r(I).innerText
       Next I
   End With
End Sub

Sub 提取网页第2页()
  With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=30"
        Do Until .ReadyState = 4
            DoEvents
        Loop
       Set r = .Document.All.tags("td")
       For I = 0 To r.Length - 1
       Cells(I + 1, 2) = r(I).innerText
       Next I
   End With
End Sub
'--------------------------





Sub 提取网页第64页()
  With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=1890"
        Do Until .ReadyState = 4
            DoEvents
        Loop
       Set r = .Document.All.tags("td")
       For I = 0 To r.Length - 1
       Cells(I + 1, 64) = r(I).innerText
       Next I
   End With
End Sub

gdw831001

楼主在我这代码测试没有用，可能是浏览器不行吧，，如果楼主要循环，试下这个代码

1. Sub 提取网页第1页()
   
2.     For y = 0 To 1890 Step 30
   
3.         With CreateObject("InternetExplorer.Application")
   
4.             .Visible = True
   
5.             .Navigate "https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & y
   
6.             Do Until .ReadyState = 4
   
7.                 DoEvents
   
8.             Loop
   
9.             Set r = .Document.All.tags("td")
   
10.             x = 1 + x
    
11.             For I = 0 To r.Length - 1
    
12.                 Cells(I + 1, x) = r(I).innerText
    
13.             Next I
    
14.         End With
    
15.     Next
    
16. End Sub

复制代码

孤独骑士

1. Sub 提取报名表()
   
2.     On Error Resume Next
   
3.     Application.ScreenUpdating = False
   
4.     Dim arr(), x%
   
5.     Range("a1").Resize(1, 4) = Split("姓名,性别,就读学校,报名所在地", ",")
   
6.     For x = 0 To 63
   
7.         s = getXmlHttpText("https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=" & application.min(x*30,1890))
   
8.         s = regReplace(s, "\s+", "")
   
9.         Set m = regMatch(s, "</tr><tr><td>(.*?)</td><td>(.*?)</td><td>(.*?)</td><td>(.*?)</td>")
   
10.         ReDim arr(1 To m.Count, 1 To 4)
    
11.         For i = 1 To UBound(arr)
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 arr(i, j) = m(i - 1).submatches(j - 1)
    
14.             Next
    
15.         Next
    
16.         Range("a" & x * 30 + 2).Resize(UBound(arr), 4) = arr
    
17.         Erase arr
    
18.     Next x
    
19.     Application.ScreenUpdating = True
    
20. End Sub
    
21. Function getXmlHttpText(url)
    
22.     Dim strText    ' As String
    
23.     With CreateObject("MSXML2.XMLHTTP")    'CreateObject("WinHttp.WinHttpRequest.5.1")
    
24.         .Open "GET", url, False
    
25.         .Send
    
26.         getXmlHttpText = .responsetext
    
27.     End With
    
28. End Function
    
29. Function regReplace(s, pstrt, rstr)
    
30.     Dim regex As Object
    
31.     Dim temp, n
    
32.     n = Len(s)
    
33.     Set regex = CreateObject("VBScript.RegExp")
    
34.     With regex
    
35.         .Global = True
    
36.         .Pattern = pstrt
    
37.         temp = .Replace(s, rstr)
    
38.     End With
    
39.     regReplace = temp
    
40.     Set regex = Nothing
    
41. End Function
    
42. Function regMatch(s, pString)
    
43.     Dim regex As Object
    
44.     Dim temp, n
    
45.     Set regex = CreateObject("VBScript.RegExp")
    
46.     With regex
    
47.         .Global = True
    
48.         .IgnoreCase = True
    
49.         .Pattern = pString
    
50.         Set matchs = .Execute(s)    '返回一个集合
    
51.     End With
    
52.     Set regex = Nothing
    
53.     Set regMatch = matchs
    
54.     Set matchs = Nothing
    
55. End Function

复制代码

一共1920条记录，全取出来了。不过要花点时间运行

LMY123

孤独骑士 发表于 2015-10-4 00:13
一共1920条记录，全取出来了。不过要花点时间运行

非常感谢大师的热情帮助，问题已顺利解决

liucqa

这个网站以后能用上                                     。

onlycxb

https://gaokao.chsi.com.cn/zzbm/ ... mp;lx=1&start=0
这个网站可能是最简单的数据网页了。唯一变化的参数就是start=（ 页码-1）*30

阳光高考这个网站信息可能更多的学生和家长观注。

LMY123

onlycxb 发表于 2015-10-5 11:57
https://gaokao.chsi.com.cn/zzbm/mdgs/detail.action?oid=476733931&lx=1&start=0
这个网站可能是最简单 ...

谢谢老师关注，能帮我看看这个问题吗？
http://club.excelhome.net/thread-1241066-1-1.html

lindaomi

MARK，感谢。

ranger丶亦

学习一下，占个位