[已解决]提取一所高校2015年所有省份的招生计划

LMY123

上海交通大学2015年高校各专业录取计划明细.rar (14.31 KB, 下载次数: 61)

2015-11-12 18:50 上传

点击文件名下载附件

YZC51

1. Sub test1() 'È¡1000ÆÚ
   
2.     '[A:J].Clear
   
3.     URL = "http://www.eol.cn/html/gkcx/jh2015/31/125.htm"
   
4.     With ActiveSheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=[a2])
   
5.         .WebFormatting = 0 'xlWebFormattingNone 'Ö¸¶¨ÊÇ·ñ°üº¬¸ñʽ
   
6.        ' .WebSelectionType = 0 'xlSpecifiedTables 'Ö¸¶¨tableģʽ
   
7.         .WebTables = "2" 'µÚ2ÕÅtable
   
8.        .Refresh 'False
   
9.        ' .[1:3].Delete
   
10.         '[C:C].Font.ColorIndex = 56
    
11.     End With
    
12. End Sub

复制代码

LMY123

YZC51 发表于 2015-11-12 19:44

是我没说清楚，其实我想要所有省的，每个省的网址如下
http://www.eol.cn/html/gkcx/jh2015/34/125.htm        安徽
http://www.eol.cn/html/gkcx/jh2015/11/125.htm        北京
http://www.eol.cn/html/gkcx/jh2015/50/125.htm        重庆
http://www.eol.cn/html/gkcx/jh2015/35/125.htm        福建
http://www.eol.cn/html/gkcx/jh2015/62/125.htm        甘肃
http://www.eol.cn/html/gkcx/jh2015/44/125.htm        广东
http://www.eol.cn/html/gkcx/jh2015/45/125.htm        广西
http://www.eol.cn/html/gkcx/jh2015/52/125.htm        贵州
http://www.eol.cn/html/gkcx/jh2015/46/125.htm        海南
http://www.eol.cn/html/gkcx/jh2015/13/125.htm        河北
http://www.eol.cn/html/gkcx/jh2015/41/125.htm        河南
http://www.eol.cn/html/gkcx/jh2015/23/125.htm        黑龙江
http://www.eol.cn/html/gkcx/jh2015/42/125.htm        湖北
http://www.eol.cn/html/gkcx/jh2015/43/125.htm        湖南
http://www.eol.cn/html/gkcx/jh2015/22/125.htm        吉宁
http://www.eol.cn/html/gkcx/jh2015/32/125.htm        江苏
http://www.eol.cn/html/gkcx/jh2015/36/125.htm        江西
http://www.eol.cn/html/gkcx/jh2015/21/125.htm        辽宁
http://www.eol.cn/html/gkcx/jh2015/21/125.htm        辽宁
http://www.eol.cn/html/gkcx/jh2015/15/125.htm        内蒙古
http://www.eol.cn/html/gkcx/jh2015/64/125.htm        宁夏
http://www.eol.cn/html/gkcx/jh2015/63/125.htm        青海
http://www.eol.cn/html/gkcx/jh2015/37/125.htm        山东
http://www.eol.cn/html/gkcx/jh2015/14/125.htm        山西
http://www.eol.cn/html/gkcx/jh2015/61/125.htm        陕西
http://www.eol.cn/html/gkcx/jh2015/31/125.htm        上海
http://www.eol.cn/html/gkcx/jh2015/51/125.htm        四川
http://www.eol.cn/html/gkcx/jh2015/12/125.htm        天津
http://www.eol.cn/html/gkcx/jh2015/54/125.htm        西藏
http://www.eol.cn/html/gkcx/jh2015/65/125.htm        新疆
http://www.eol.cn/html/gkcx/jh2015/53/125.htm        云南
http://www.eol.cn/html/gkcx/jh2015/33/125.htm        浙江

onlycxb

1. Sub t()
   
2.     Dim objh As Object, db
   
3.     Set objh = CreateObject("htmlfile")
   
4.     With CreateObject("msxml2.xmlhttp")
   
5.         .Open "GET", "http://www.eol.cn/html/gkcx/jh2015/31/125.htm", False
   
6.         .send
   
7.         s = .responsetext
   
8.     End With
   
9.     s = Mid(s, InStr(s, "<table id=""demotable1"">"))
   
10.     s = Left(s, InStr(s, "</table>") + 7)
    
11. 
    
12.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
13.         .SetText s
    
14.         .PutInClipboard
    
15.     End With
    
16.     Cells.Clear
    
17.     Range("a1").Select
    
18.     ActiveSheet.Paste
    
19. End Sub
    

复制代码

LMY123

YZC51 发表于 2015-11-12 19:44

谢谢老师的指点，能把所有省份的都提出来吗？

YZC51

URL = http://www.eol.cn/html/gkcx/jh2015/31/125.htm
修改红色部分即可

YZC51

请参考行政区划代码！！！
11        北京市
12        天津市
13        河北省
13        河北省廊坊市
14        山西省
14        山西省临汾市
15        内蒙古自治区
21        辽宁省
21        辽宁省辽阳市
22        吉林省
23        黑龙江省
23        黑龙江省牡丹江市
31        上海市
32        江苏省
32        江苏省扬州市
33        浙江省
33        浙江省台州市
34        安徽省
34        安徽省黄山市
35        福建省
36        江西省
36        江西省抚州市
37        山东省
37        山东省威海市
37        山东省胜利油田
41        河南省
41        河南省许昌市
42        湖北省
42        湖北省荆州市
42        湖北省省直辖行政单位
43        湖南省
43        湖南省郴州市
44        广东省
44        广东省中山市
45        广西壮族自治区
45        广西百色市
46        海南省
46        海南省省直辖县级行政单位
50        重庆市
51        四川省
51        四川省内江市
51        四川省资阳市
52        贵州省
53        云南省
54        西藏自治区
61        陕西省
61        陕西省商洛市
62        甘肃省
62        甘肃省庆阳市
62        甘肃省甘南藏族自治州
63        青海省
64        宁夏回族自治区
65        新疆维吾尔自治区
65        新疆克孜勒苏柯尔克孜自治州
65        新疆伊犁哈萨克自治州
65        新疆省直辖行政单位
71        台湾省
81        香港特别行政区
82        澳门特别行政区

LMY123

能不能一次性把所有省份的全部提取出来呢？

LMY123

Sub 怎么去掉对话框()

For y = 1 To 500
Application.DisplayAlerts = False
    URL = "http://www.eol.cn/html/gkcx/jh2015/11/" & y & ".htm"
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=[a2])
        .WebFormatting = 0 '

        .WebTables = "2" '
       .Refresh 'False

    End With
    Application.DisplayAlerts = False
    Next y
End Sub

jpj123

做好了一键提取所有省份的数据，请测试代码：

1. Public Sub test()
   
2. Dim Str$, url$, i%, n%, j%, db, tr, td, Str2$, db2, tr2, td2
   
3. Dim html As Object, arr, brr, Reg, mh, k, r%
   
4. Set Reg = CreateObject("vbscript.regexp")
   
5. Set html = CreateObject("htmlfile")
   
6. Application.ScreenUpdating = False
   
7. url = "http://www.eol.cn/html/gkcx/jh2015/31/125.htm"
   
8. With CreateObject("msxml2.xmlhttp")
   
9.     .Open "GET", url, False
   
10.     .send
    
11.     Str = .responsetext
    
12.     '-------------------------------------------------------
    
13.     Str2 = Split(Split(Str, "<table width=""93%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""0"">")(1), "</table>")(0)
    
14.     Str2 = "<table width=""93%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""0"">" & Str2
    
15. With Reg
    
16.     .Pattern = "<a.*/([0-9]{2})/[^一-龥]+([一-龥]{2,5}){1}</a>" '
    
17.     ''<a href="../34/125.htm">安徽</a></
    
18.     .Global = True
    
19.     Set mh = Reg.Execute(Str2)
    
20.     ReDim brr(1 To mh.Count, 1 To 2)
    
21.     For Each k In mh
    
22.         n = n + 1
    
23.         brr(n, 2) = k.submatches(0)
    
24.         brr(n, 1) = k.submatches(1)
    
25.     Next
    
26. End With
    
27. '---------------------------------------------------------
    
28. Cells.Clear
    
29. For r = 1 To n
    
30.     url = "http://www.eol.cn/html/gkcx/jh2015/" & brr(r, 2) & "/125.htm"
    
31.     .Open "GET", url, False
    
32.     .send
    
33.     Str = .responsetext
    
34.     html.body.innerhtml = Str
    
35.     Set db = html.all.tags("table")("demotable1") '<table id="demotable1">
    
36.     i = 0: n = 0: n = db.Rows.Length
    
37.     ReDim arr(1 To n, 1 To 8)
    
38.         For Each tr In db.Rows
    
39.             i = i + 1: j = 0
    
40.             For Each td In tr.Cells
    
41.                 j = j + 1
    
42.                 arr(i, j) = td.innertext
    
43.             Next
    
44.         Next
    
45.         If r = 1 Then
    
46.             Range("A65536").End(3) = brr(r, 1)
    
47.                 Else
    
48.             Range("A65536").End(3).Offset(1) = brr(r, 1)
    
49.         End If
    
50.     Range("A65536").End(3).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
51.     Set db = Nothing
    
52. Next
    
53. End With
    
54. Application.ScreenUpdating = True
    
55. MsgBox "完成!"
    
56. End Sub
    

复制代码