Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 315|回复: 9

[已解决] Excel如何将多页网页表格批量导入一张Excel表,并可以每天刷新

[复制链接]
发表于 2017-11-9 17:27 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
我想把该网址“http:||data.eastmoney.com/stockcomment/”中全部股票的71页,导入一个Excel中,而不用每天都全部复制粘贴。
在过去的两年一直是手动复制的,实在不想复制了太麻烦了。试过很多方法也看了很多帖子,无奈,隔行如隔山。恳请哪位高手帮助写个代码或做个Excel,不胜感激!可以微信发红包以示感谢!

 楼主| 发表于 2017-11-9 17:28 | 显示全部楼层
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-9 17:28 | 显示全部楼层
回复 支持 反对

使用道具 举报

发表于 2017-11-9 20:28 | 显示全部楼层
  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
复制代码


东方财富.rar

288.89 KB, 下载次数: 18

评分

参与人数 2经验 +13 收起 理由
990571687 + 1 很给力
苏子龙 + 12 神马都是浮云

查看全部评分

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-10 22:39 | 显示全部楼层

谢谢,辛苦了!!请留个卡号或手机号微信号等,我希望能为知识付费,真诚地感谢你的帮助。
回复 支持 反对

使用道具 举报

发表于 2017-11-11 11:24 | 显示全部楼层
990571687 发表于 2017-11-10 22:39
谢谢,辛苦了!!请留个卡号或手机号微信号等,我希望能为知识付费,真诚地感谢你的帮助。

为你的诚信点赞!这代码奖励给你了!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-11 13:30 | 显示全部楼层
today0427 发表于 2017-11-11 11:24
为你的诚信点赞!这代码奖励给你了!

谢谢,好人一生平安!
回复 支持 反对

使用道具 举报

发表于 2017-11-29 16:07 | 显示全部楼层
网站改版了,我抓包出来的网址和以前完全不同了。给你修改了,现在能用,据有经验的老师说改版就是分分钟的事情,后面要是不停改版我也帮不了你了。不过改版以后变成规范的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
复制代码


东方财富修改.rar

597.55 KB, 下载次数: 9

评分

参与人数 1经验 +1 收起 理由
990571687 + 1 很给力

查看全部评分

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2018-1-19 21:22 , Processed in 0.083802 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表