ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 15347|回复: 17

[求助] 怎样把网页中的内容自动抓取到excel表格中并且实时刷新?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-12-14 21:00 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 a704019026 于 2016-12-14 21:04 编辑

如图,我想抓取这个网页中http://gu.qq.com/sz002811?pgv_ref=fi_quote_my_select,右下部位如图中,“热门股票排行榜“”的内容。想要得到的结果如图。求大神帮忙,编个VBA程序,能实时根据网页数据变化,EXCEL表格中的内容也随之变化。谢谢啦!!

想要抓取的网页内容

想要抓取的网页内容

想要得到的结果

想要得到的结果

工作簿1.rar

9.58 KB, 下载次数: 139

TA的精华主题

TA的得分主题

发表于 2016-12-15 08:08 | 显示全部楼层
本帖最后由 Kaohsing 于 2016-12-15 08:47 编辑

你是从http://gu.qq.com/这个主页怎么一步步选择跳转到http://gu.qq.com/sz002811?pgv_ref=fi_quote_my_select???

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-15 08:51 | 显示全部楼层
不是的  直接进那个连接就可以的  能帮忙看下不??

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-15 08:53 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
http://gu.qq.com/sz000001这个网页也有 都可以

TA的精华主题

TA的得分主题

发表于 2016-12-15 09:46 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-15 10:55 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-12-15 16:01 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
时时更新谈不上,只是个别数据有时对不上,中文标题能对上号,用正则简单处理了一
  1. Sub getData()
  2.    
  3.      Dim url$, XML, str$
  4.      url = "http://web.ifzq.gtimg.cn/appstock/app/HotStock/getHotRankIndex?_var=hotRank&" & Rnd()
  5.      Set XML = CreateObject("MSXML2.XMLHTTP")
  6.      Cells.Clear
  7.      With XML
  8.       .Open "GET", url, False
  9.       .send
  10.       str = StrConv(.responsebody, 64)
  11.      End With
  12.    
  13.      Dim regx As Object, I%, j%, arr()
  14.     Set regx = CreateObject("vbscript.regexp")
  15.     regx.Pattern = "index"":""(.*?)"",""symbol"":""(.*?)"",""rankdelta"":""(.*?)"",""rank"":""(.*?)"",""level"":""(.*?)"",""name"":""(.*?)"",""zdf"":""(.*?)""}"
  16.     regx.MultiLine = True   '多行
  17.     regx.Global = True
  18.     Set mh = regx.Execute(str)
  19.     op = Split(str, "rankTime"":""")(1)
  20.     ReDim Preserve arr(1 To mh.Count, 1 To 7)
  21.      For I = 0 To mh.Count - 1
  22.           m = m + 1
  23.        For j = 0 To mh(I).submatches.Count - 1
  24.          arr(m, j + 1) = StringConv(mh(I).submatches(j))
  25.        Next
  26.      Next '"rankTime":"12-15 14:45:01"}}}
  27.    [a1].Resize(1, 7) = Split("index 股票代码 rankdelta rank level 股票名称 涨幅")
  28.    [a2].Resize(m, 7) = arr
  29.    [h2] = "5分钟最热" & Split(Split(str, "rankTime"":""")(1), """}")(0): Range("H2:H11").Merge
  30.    [h12] = "1小时最热" & Split(Split(str, "rankTime"":""")(2), """}")(0): Range("H12:H21").Merge
  31.    [h22] = "今日最热" & Split(Split(str, "rankTime"":""")(3), """}")(0): Range("H22:H31").Merge
  32.    [h32] = "7日最热" & Split(Split(str, "rankTime"":""")(4), """}")(0):  Range("H32:H41").Merge
  33. End Sub
  34. Function StringConv(ByVal Str1 As String) As String
复制代码

截图

截图

TA的精华主题

TA的得分主题

发表于 2016-12-15 16:02 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
a704019026 发表于 2016-12-15 10:55
怎样写代码呀?
能帮我写下不??

代码正在审核Sub getData()

     Dim url$, XML, str$
     url = "http://web.ifzq.gtimg.cn/appstock/app/HotStock/getHotRankIndex?_var=hotRank&" & Rnd()
     Set XML = CreateObject("MSXML2.XMLHTTP")
     Cells.Clear
     With XML
      .Open "GET", url, False
      .send
      str = StrConv(.responsebody, 64)
     End With

     Dim regx As Object, I%, j%, arr()
    Set regx = CreateObject("vbscript.regexp")
    regx.Pattern = "index"":""(.*?)"",""symbol"":""(.*?)"",""rankdelta"":""(.*?)"",""rank"":""(.*?)"",""level"":""(.*?)"",""name"":""(.*?)"",""zdf"":""(.*?)""}"
    regx.MultiLine = True   '多行
    regx.Global = True
    Set mh = regx.Execute(str)
    op = Split(str, "rankTime"":""")(1)
    ReDim Preserve arr(1 To mh.Count, 1 To 7)
     For I = 0 To mh.Count - 1
          m = m + 1
       For j = 0 To mh(I).submatches.Count - 1
         arr(m, j + 1) = StringConv(mh(I).submatches(j))
       Next
     Next '"rankTime":"12-15 14:45:01"}}}
   [a1].Resize(1, 7) = Split("index 股票代码 rankdelta rank level 股票名称 涨幅")
   [a2].Resize(m, 7) = arr
   [h2] = "5分钟最热" & Split(Split(str, "rankTime"":""")(1), """}")(0): Range("H2:H11").Merge
   [h12] = "1小时最热" & Split(Split(str, "rankTime"":""")(2), """}")(0): Range("H12:H21").Merge
   [h22] = "今日最热" & Split(Split(str, "rankTime"":""")(3), """}")(0): Range("H22:H31").Merge
   [h32] = "7日最热" & Split(Split(str, "rankTime"":""")(4), """}")(0):  Range("H32:H41").Merge
End Sub
Function StringConv(ByVal Str1 As String) As String
  Dim I  As Long
  Dim strArr()  As String
  Dim RegExp    As Object
  Dim Match     As Object

  On Error Resume Next
  Set RegExp = CreateObject("VBScript.RegExp")
  If RegExp Is Nothing Then Exit Function
  With RegExp
    .Pattern = "\\u[A-F\d]{2,4}(?=\b)"
    .Global = True
    .IgnoreCase = True
    Set Match = .Execute(Str1)
    For I = 0 To Match.Count - 1
      Str1 = Replace(Str1, Match(I), ChrW(Replace(Match(I), "\u", "&H", 1, , vbTextCompare)))
    Next I
  End With
  Set Match = Nothing
  Set RegExp = Nothing
  StringConv = Str1
End Function

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-12-16 07:42 | 显示全部楼层
Kaohsing 发表于 2016-12-15 16:02
代码正在审核Sub getData()

     Dim url$, XML, str$

非常感谢 嘿嘿

TA的精华主题

TA的得分主题

发表于 2016-12-16 07:45 | 显示全部楼层

非常复杂的json格式,只好用正则啦(split没法用)
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-18 10:49 , Processed in 0.044707 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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