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

jpj123

一次性提取所有省份，详见附件

LMY123

jpj123 发表于 2015-11-14 18:15
一次性提取所有省份，详见附件

非常感谢，效果非常好，能不能进一步把下面网站里所有高校或者一个省（市）的所有高校全部提取出来呢？      http://www.eol.cn/html/gkcx/jh2015/      

YZC51

LMY123 发表于 2015-11-14 13:56
Sub 怎么去掉对话框()

For y = 1 To 500

请参考

1. Sub Ôõôȥµô¶Ô»°¿ò()
   
2.     Application.DisplayAlerts = False
   
3.     For y = 31 To 35 '3197
   
4.     On Error Resume Next
   
5.        hh = [A65536].End(xlUp).Row + 1
   
6.         URL = "http://www.eol.cn/html/gkcx/jh2015/11/" & y & ".htm"
   
7.         
   
8.         With CreateObject("msxml2.xmlhttp")
   
9.             .Open "GET", URL, False
   
10.             .send
    
11.             str1 = .responsetext
    
12.         End With
    
13.         Range("A" & hh) = Split(Split(str1, "<title>")(1), "-")(0)
    
14.         With ActiveSheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=Range("A" & hh + 1))
    
15.             .WebFormatting = 0 '
    
16.             .WebTables = "2" '
    
17.             .Refresh False
    
18.         End With
    
19.     Next y
    
20.     hh = [A65536].End(xlUp).Row
    
21.     Range("A" & hh) = ""
    
22.     Application.DisplayAlerts = 1
    
23. End Sub

复制代码

LMY123

YZC51 发表于 2015-11-15 13:45
请参考

谢谢老师的再次指导，能否单独把所有高校的代码或者网址提取出来？
  http://www.eol.cn/html/gkcx/jh2015/   

YZC51

请测试

1. Sub xxx()
   
2.     Application.ScreenUpdating = 0
   
3. 
   
4.     With CreateObject("Msxml2.ServerXMLHTTP")
   
5.          URL = "http://www.eol.cn/html/gkcx/jh2015/"
   
6.          .Open "GET", URL, False
   
7.          .send
   
8.          stext = .responsetext
   
9.      End With
   
10.             
    
11.     stext = Replace(stext, "<div class=""dr"">", "<")
    
12.     stext = Replace(stext, "<div class=""time"">", "<")
    
13.     stext = Replace(stext, "<div class=""ball"">", ",")
    
14. 
    
15.     strText = strText & "<table>" & Split(Split(stext, "&Ograve;&Ocirc;&Iuml;&Acirc;&cedil;&szlig;&ETH;&pound;°&acute;&Ecirc;&iexcl;·&Yacute;&Aring;&Aring;&ETH;ò")(1), "<h3></h3>")(0) & "</table>"
    
16. 
    
17.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
18.         .SetText strText
    
19.         .PutInClipboard
    
20.     End With
    
21.         
    
22.     t = [a65536].End(3).Row + 1
    
23.    
    
24.     Range("A" & t).Select
    
25.     ActiveSheet.Paste
    
26.    
    
27.     'Columns("A:A").TextToColumns Destination:=Range("A1"), Comma:=True
    
28. '    [b1].Delete
    
29. '    t = [a65536].End(3).Row
    
30. '    ActiveSheet.Range("a2:c" & t).Sort Range("c2"), 1
    
31. '    [b:b].NumberFormatLocal = "@" ' "000000"
    
32. '    [b:b].NumberFormatLocal = "00000"
    
33. '    [C:C] = ""
    
34.     [a1].Select
    
35.     Application.ScreenUpdating = 1
    
36. 
    
37. End Sub

复制代码

YZC51

LMY123 发表于 2015-11-15 17:58
谢谢老师的再次指导，能否单独把所有高校的代码或者网址提取出来？
  http://www.eol.cn/html/gkcx/jh20 ...

请测试

1. Sub xxx()
   
2.     Application.ScreenUpdating = 0
   
3. 
   
4.     With CreateObject("Msxml2.ServerXMLHTTP")
   
5.          URL = "http://www.eol.cn/html/gkcx/jh2015/"
   
6.          .Open "GET", URL, False
   
7.          .send
   
8.          stext = .responsetext
   
9.      End With
   
10.             
    
11.    stext = Replace(stext, "<a href=""", "<a>" & URL)
    
12.     stext = Replace(stext, """>", ",")
    
13. 
    
14.     strText = strText & "<table>" & Split(Split(stext, "&Ograve;&Ocirc;&Iuml;&Acirc;&cedil;&szlig;&ETH;&pound;°&acute;&Ecirc;&iexcl;·&Yacute;&Aring;&Aring;&ETH;ò")(1), "<h3></h3>")(0) & "</table>"
    
15. 
    
16.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
17.         .SetText strText
    
18.         .PutInClipboard
    
19.     End With
    
20.         
    
21.     t = [a65536].End(3).Row + 1
    
22.    
    
23.     Range("A" & t).Select
    
24.     ActiveSheet.Paste
    
25.    
    
26.     Columns("A:A").TextToColumns Destination:=Range("A1"), Comma:=True
    
27. [a1].Select
    
28.     Application.ScreenUpdating = 1
    
29. 
    
30. End Sub

复制代码

YZC51

或者

1. Sub xxx1()
   
2.     Application.ScreenUpdating = 0
   
3.     With CreateObject("Msxml2.ServerXMLHTTP")
   
4.          URL = "http://www.eol.cn/html/gkcx/jh2015/"
   
5.          .Open "GET", URL, False
   
6.          .send
   
7.          stext = .responsetext
   
8.     End With
   
9.     stext = Replace(stext, "<a href=""", "<a href=""" & URL)
   
10.     strText = "<table>" & Split(Split(stext, "以下高校按省份排序")(1), "<h3></h3>")(0) & "</table>"
    
11. 
    
12.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
13.         .SetText strText
    
14.         .PutInClipboard
    
15.     End With
    
16.     t = [a65536].End(3).Row + 1
    
17.     Range("A" & t).Select
    
18.     ActiveSheet.Paste
    
19.     [a1].Select
    
20.     Application.ScreenUpdating = 1
    
21. End Sub

复制代码

在和弦处等你

Power Query，

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

2015-11-16 08:31 上传

点击文件名下载附件

LMY123

在和弦处等你 发表于 2015-11-16 08:31
Power Query，

请问大师，附件中怎么没看见代码呢？

LMY123

YZC51 发表于 2015-11-15 18:59
请测试

strText = strText & "<table>" & Split(Split(stext, "ò&#212;&#207;&#194;&#184;&#223;D￡°′ê&#161;·Y&#197;&#197;Dò")(1), "<h3></h3>")(0) & "</table>"
请问大师，为何运行到这一句显示下标越界呢？