[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

[文本处理] 【已解决】批处理获取网页数据 并存为excel

本帖最后由 uuu888s 于 2015-3-14 17:47 编辑

打开http://data.eastmoney.com/soft/zlsj/xt.html

可看到下面的 信托机构总览里的数百家机构    现在要把所有信托机构的名称及该信托机构对应的总的持股市值(亿元)
保存在本地xls文件里的两列  一列为信托机构名称 一列为对应的总的持股市值(亿元)

总的持股市值(亿元)来源 点击任意机构链接 可以看到  (有多个持股市值(亿元)的 要相加)
机构相关数据如下
http://data.eastmoney.com/aspx/data.aspx?name=RptOrganizationPositionsChange&orgId=GD051739&reportDate=20141231&sortType=5&sortRule=-1&jsname=okrOaEln   
不同机构更改orgId即可
1

评分人数

    • Batcher: 感谢给帖子标题标注[已解决]字样PB + 2
不要哭让萤火虫带着你逃跑 乡间的歌谣永远的依靠

仅针对这一个网站吗?

TOP

仅针对这一个网站吗?

TOP

本帖最后由 uuu888s 于 2015-3-13 12:38 编辑

回复 2# Eric_Lyly


是的

TOP

需要第三方工具, NC CURL 之类的

TOP

本帖最后由 apang 于 2015-3-15 16:29 编辑
  1. call Main()
  2. Sub Main()
  3.         Dim url, txt, arr, i
  4.         url = "http://data.eastmoney.com/soft/zlsj/jgcg.aspx?typename=Intrust&year=2014&month=12"
  5.         txt = getText(url)
  6.         arr = getOrgID(txt)
  7.         For i = 0 to UBound(arr, 2)
  8.                 url = "http://data.eastmoney.com" & arr(0, i)
  9.                 arr(0, i) = getTDNum(getText(url)) & " " & url
  10.                 WScript.Sleep 1000
  11.         Next
  12.         call SaveToFile(arr)
  13. End Sub
  14. MsgBox "OK"
  15. Function getText(ByVal url)
  16.         Dim http
  17.         Set http = CreateObject ("Microsoft.XMLHTTP")
  18.         http.Open "GET", url, false
  19.         http.Send
  20.         with CreateObject("ADODB.Stream")
  21.                 .Mode = 3
  22.                 .Type = 1
  23.                 .Open
  24.                 .Write http.responseBody
  25.                 .Position = 0
  26.                 .Type = 2
  27.                 .Charset = "GB2312"
  28.                 getText = .ReadText()
  29.         End with
  30. End Function
  31. Function getOrgID(ByVal txt)
  32.         Dim ar, re, e, i
  33.         ReDim ar(1, 0)
  34.         txt = Split(txt, "信托机构总览")(1)
  35.         Set re = New RegExp
  36.         re.Pattern = "href=""(.+?)"".+?>(.+?)<"
  37.         re.Global = true
  38.         re.IgnoreCase = true
  39.         Set e = re.Execute(txt)
  40.         For i = 0 to e.Count - 1
  41.                 ReDim PreServe ar(1, i)
  42.                 ar(0, i) = e(i).Submatches(0)
  43.                 ar(1, i) = e(i).Submatches(1)
  44.         Next
  45.         getOrgID = ar
  46. End Function
  47. Function getTDNum(s)
  48.         Dim re, m, n
  49.         Set re = New RegExp
  50.         re.Pattern = "tdnumber col.+?tdnumber.+?([\d\.]+)"
  51.         re.Global = true
  52.         re.IgnoreCase = true
  53.         If Not re.Test(s) Then getTDNum = "-" : Exit Function
  54.         For Each m in re.Execute(s)
  55.                 n = n + 0 + m.SubMatches(0)
  56.         Next
  57.         getTDNum = n
  58. End Function
  59. Sub SaveToFile(ByVal arr)
  60.         Dim p, oExcel, i, lnk
  61.         p = Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\"))
  62.         Set oExcel = CreateObject("Excel.Application")
  63.         oExcel.Visible = false
  64.         oExcel.WorkBooks.Add
  65.         oExcel.WorkSheets(1).Activate
  66.         For i = 0 to UBound(arr, 2)
  67.                 lnk = Split(arr(0, i), " ")(1)
  68.                 oExcel.Cells(i+2, 1) = arr(1, i)
  69.                 oExcel.Cells(i+2, 2) = Split(arr(0, i), " ")(0)
  70.                 oExcel.WorkSheets(1).HyperLinks.Add oExcel.Cells(i+2,1), lnk
  71.         Next
  72.         oExcel.Cells(1, 1) = "信托机构名称"
  73.         oExcel.Cells(1, 2) = "持股市值"
  74.         oExcel.ActiveWorkBook.SaveAs p & "a.xlsx"
  75.         oExcel.WorkBooks.Close
  76.         oExcel.Quit
  77. End Sub
复制代码
1

评分人数

TOP

回复 5# caruko


    昂?nc 还能干这个,求教育

TOP

本帖最后由 uuu888s 于 2015-3-14 22:27 编辑

:) :) :):) :) :)
不要哭让萤火虫带着你逃跑 乡间的歌谣永远的依靠

TOP

回复 8# uuu888s


    已修改,以后把要求一次性说清楚
1

评分人数

TOP

本帖最后由 uuu888s 于 2015-3-14 18:03 编辑

回复 9# apang


    不好意思啊 不过链接内容搞错了 是这样的 http://data.eastmoney.com/Soft/zlsj/jgcg_ccbd.aspx?typename=xt&year=2014&month=12&orgId=(对应的id)
不要哭让萤火虫带着你逃跑 乡间的歌谣永远的依靠

TOP

回复 10# uuu888s


    哦,改了,应该没问题了
1

评分人数

TOP

返回列表