ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: onlycxb

[分享] 东方财富网天天练

  [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-3-29 21:45 | 显示全部楼层
补9:

数据采集网址是http://quote.eastmoney.com/center/list.html#33,实现代码所对应的涨跌幅数值
行情中心首页 > 沪深股市 > 沪深A股

  1. 'GET http://hqdigi2.eastmoney.com/EM_Quote2010NumericApplication/index.aspx?type=s&sortType=C&sortRule=-1&pageSize=20&page=1&jsName=quote_123&style=33&token=44c9d251add88e27b65ed86506f6e5da&_g=0.4773907992057502
  2. Sub test()
  3.     Dim strJs, P, arr
  4.     Cells.ClearContents
  5.     With CreateObject("Microsoft.XMLHTTP")
  6.         .Open "GET", "http://hqdigi2.eastmoney.com/EM_Quote2010NumericApplication/index.aspx?type=s&sortType=C&sortRule=-1&pageSize=1&page=1&jsName=a&style=33&token=44c9d251add88e27b65ed86506f6e5da&_g=" & Rnd, False
  7.         .send
  8.         P = Split(Split(.responsetext, "pages:")(1), "}")(0)
  9.         .Open "GET", "http://hqdigi2.eastmoney.com/EM_Quote2010NumericApplication/index.aspx?type=s&sortType=C&sortRule=-1&pageSize=" & P & "&page=1&jsName=a&style=33&token=44c9d251add88e27b65ed86506f6e5da&_g=" & Rnd, False
  10.         .send
  11.         strJs = .responsetext & ";var b=a.rank;var s=''; for(x in b){ y=b[x].split(',');s+=y.slice(1,3)+'\t'+ y.slice(11,12)+'\r'} "
  12.     End With
  13.     With CreateObject("MSScriptControl.ScriptControl")
  14.         .Language = "javascript"
  15.         strJs = .eval(strJs)
  16.         Debug.Print strJs
  17.     End With
  18.     Debug.Print strJs
  19.     arr = Split(strJs, vbCr)

  20.     With ActiveSheet
  21.         .[a2].Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
  22.         .[a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=False, Tab:=True, Comma:=True, FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 1))
  23.     End With
  24. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-3-29 21:54 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
test9.rar (92.38 KB, 下载次数: 432)

TA的精华主题

TA的得分主题

发表于 2015-3-29 22:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
市场代码        查询代码        股票代码        股票简称        最近股东大会:       
0           sz002337        002337        赛象科技               
1           sh601012        601012        隆基股份               
0           sz300055        300055        万邦达
提取查询代码后,逐一打开个股公司大事网页,提取其中一项最近股东大会的信息
根据学习楼主的代码,写了以下代码,发现以下问题:

1、弹出对话框,询问是否允许存网站COOKIE
2、只能打开第一个查询代码的网页

请楼主,有空帮看看,非常感谢!

Sub t()
    Dim html, db, i%, j%, k%, ii%, tr, td, arr(1 To 100000, 1 To 10)
    URL = "http://f10.eastmoney.com/f10_v2/CompanyBigNews.aspx?code="
    Set html = CreateObject("htmlfile")
    For ii = 2 To 4
    Url1 = Sheet2.Cells(ii, 2)
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL & Url1, False
        .send
        html.write .responsetext
    End With
    Set db = html.all.tags("table")
    For i = 0 To db.Length - 1
        If db(i).classname = "listTable" Then
            For Each tr In db(i).Rows
                j = j + 1
                k = 0
                For Each td In tr.Cells
                    k = k + 1
                    arr(j, k) = td.innertext
                Next td
            Next tr
        End If
    Next i
    [a1].Resize(6, 2) = arr
    For i = 1 To 6
        If Cells(i, 1) = "最近股东大会:" Then
         Sheet2.Cells(ii, 5) = Sheet1.Cells(i, 2)
        End If
    Next i
   
   Next
End Sub               

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-3-30 08:03 | 显示全部楼层
hwwyb 发表于 2015-3-29 22:37
市场代码        查询代码        股票代码        股票简称        最近股东大会:       
0           sz002337        002337        赛象科技               
1           sh601012         ...

26楼代码已经实现全部数据的查询,你仔细看看。

TA的精华主题

TA的得分主题

发表于 2015-3-30 09:51 | 显示全部楼层
是的,测试了,已经取到股东大会的信息了,谢谢,能否帮看一下33楼的代码的问题,学习提高

TA的精华主题

TA的得分主题

发表于 2015-4-3 10:41 | 显示全部楼层
onlycxb 发表于 2015-3-10 13:35
7.东方财富网 > 数据中心 > 年报季报 > 业绩报表

不能用了,请大师给个新代码!先谢谢啦!
数据源地址:http://data.eastmoney.com/bbsj/201412/yjbb.html

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-4-3 13:56 | 显示全部楼层
luyina 发表于 2015-4-3 10:41
不能用了,请大师给个新代码!先谢谢啦!
数据源地址:http://data.eastmoney.com/bbsj/201412/yjbb.htm ...

东方财富网 > 数据中心 > 年报季报 > 业绩报表
  1. Sub test()
  2.     Dim strJs, P
  3.     Cells.ClearContents
  4.     With CreateObject("Microsoft.XMLHTTP")
  5.         .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=SR&sty=YJBB&fd=2014-12-31&st=13&sr=-1&p=1&ps=1&js=(pc),(x)&stat=0&rt=47601296", False
  6.         .send
  7.         P = Split(.responsetext, ",")(0)
  8.         .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=SR&sty=YJBB&fd=2014-12-31&st=13&sr=-1&p=1&ps=" & P & "&js=var%20a={pages:(pc),data:[(x)]}&stat=0&rt=47601296", False
  9.         .send
  10.         
  11.          CopyToClipbox .responsetext
  12.         strJs = .responsetext & ";var b=a.data;var s=''; for(x in b){s+=b[x]+'\r';}"
  13.     End With
  14.     With CreateObject("MSScriptControl.ScriptControl")
  15.         .Language = "javascript"
  16.         strJs = .Eval(strJs)
  17.     End With
  18.     Arr = Split(strJs, vbCr)
  19.     With ActiveSheet
  20.         .[a2].Resize(UBound(Arr)) = WorksheetFunction.Transpose(Arr)
  21.        .[a:a].TextToColumns Destination:=Range("A1"), Comma:=True
  22.     End With
  23. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-4-3 14:01 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-4-3 14:06 | 显示全部楼层
luyina 发表于 2015-4-3 10:41
不能用了,请大师给个新代码!先谢谢啦!
数据源地址:http://data.eastmoney.com/bbsj/201412/yjbb.htm ...

见上传文档

TA的精华主题

TA的得分主题

发表于 2015-4-3 15:07 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 13:55 , Processed in 0.047692 second(s), 7 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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