Excel如何将多页网页表格批量导入一张Excel表，并可以每天刷新

990571687

我想把该网址“http：||data.eastmoney.com/stockcomment/”中全部股票的71页，导入一个Excel中，而不用每天都全部复制粘贴。
在过去的两年一直是手动复制的，实在不想复制了太麻烦了。试过很多方法也看了很多帖子，无奈，隔行如隔山。恳请哪位高手帮助写个代码或做个Excel，不胜感激！可以微信发红包以示感谢！

990571687

或者充手机话费也行

990571687

转账或支付宝都行，谢谢谢！

990571687

SOS

today0427

1. Sub today()
   
2.     Dim s$, objJSON As Object, o, arr(1 To 4000, 1 To 10), ar, i&, j%
   
3.     With CreateObject("MSXML2.XMLHTTP")
   
4.         .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=FD&sty=TSTC&ps=4000", False
   
5.         .Send
   
6.         s = Replace(Split(Split(.responsetext, "data:")(1), ",cdate")(0), "&sbquo", "")
   
7.         'Debug.Print s
   
8.     End With
   
9.    
   
10.     With CreateObject("msscriptcontrol.scriptcontrol")
    
11.         .Language = "javaScript"
    
12.         .addcode "var lalal=" & s
    
13.         Set objJSON = .codeobject
    
14.     End With
    
15.    
    
16.     For Each o In objJSON.lalal
    
17.         i = i + 1
    
18.         ar = Split(o, ",")
    
19.         For j = 1 To UBound(ar) + 1
    
20.             arr(i, j) = ar(j - 1)
    
21.         Next
    
22.     Next
    
23.    
    
24.     With Sheet1
    
25.         .Cells.ClearContents
    
26.         .[a1].Resize(1, 10) = Array("′úÂë", "Ãû3Æ", "2»ÖaμàêÇé¶", "Ïà1Ø", "×îD¼Û", "ÕÇμø·ù", "»»êÖÂê", "êDóˉÂê", "Ö÷á|3é±¾", "»ú112ÎóëÂê")
    
27.         .Columns("A:A").NumberFormatLocal = "@"
    
28.         .[a2].Resize(i, UBound(ar) + 1) = arr
    
29.     End With
    
30.     With ActiveWorkbook.Worksheets("Sheet1").Sort
    
31.         .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
32.         .SetRange Range("A2:J" & i + 1)
    
33.         .Header = xlNo
    
34.         .MatchCase = False
    
35.         .Orientation = xlTopToBottom
    
36.         .SortMethod = xlPinYin
    
37.         .Apply
    
38.     End With
    
39. End Sub

复制代码

990571687

today0427 发表于 2017-11-9 20:28

谢谢，辛苦了！！请留个卡号或手机号微信号等，我希望能为知识付费，真诚地感谢你的帮助。

today0427

990571687 发表于 2017-11-10 22:39
谢谢，辛苦了！！请留个卡号或手机号微信号等，我希望能为知识付费，真诚地感谢你的帮助。

为你的诚信点赞！这代码奖励给你了！

990571687

today0427 发表于 2017-11-11 11:24
为你的诚信点赞！这代码奖励给你了！

谢谢，好人一生平安！

today0427

网站改版了，我抓包出来的网址和以前完全不同了。给你修改了，现在能用，据有经验的老师说改版就是分分钟的事情，后面要是不停改版我也帮不了你了。不过改版以后变成规范的json数据了，更好处理了

1. Sub today()
   
2.     Dim s$
   
3.     Sheet1.Cells.ClearContents
   
4.         With CreateObject("MSXML2.XMLHTTP")
   
5.             .Open "GET", "http://dcfm.eastmoney.com/em_mutisvcexpandinterface/api/js/get?type=QGQP_LB&token=70f12f2f4f091e459a279469fe49eca5&ps=4000", False
   
6.             .Send
   
7.             s = .responsetext
   
8.         End With
   
9.         strHtml = "js=" & s & ";var r,c,d={},ro=co=1;for(r in js){ro++;for(c in js[r]){if(!d[c]){d[c]=co++;rng(1,d[c])=c;}rng(ro,d[c])=js[r][c];}}"
   
10.         With CreateObject("ScriptControl")
    
11.             .Language = "JScript"
    
12.             .AddObject "rng", [a2]
    
13.             .eval (strHtml)
    
14.         End With
    
15.         Sheet1.Columns("A:A").Replace What:="T00:00:00", Replacement:="", LookAt:=xlPart, _
    
16.         SearchOrder:=xlByRows
    
17. End Sub

复制代码

990571687

谢谢