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

uuu888s

打开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即可

apang

回复 10# uuu888s


    哦，改了，应该没问题了

uuu888s

回复 9# apang


    不好意思啊 不过链接内容搞错了 是这样的 http://data.eastmoney.com/Soft/zlsj/jgcg_ccbd.aspx?typename=xt&year=2014&month=12&orgId=(对应的id)

apang

回复 8# uuu888s


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

uuu888s

:) :) :):) :) :)

CrLf

回复 5# caruko


    昂？nc 还能干这个，求教育

apang

call Main()

Sub Main()
        Dim url, txt, arr, i
        url = "http://data.eastmoney.com/soft/zlsj/jgcg.aspx?typename=Intrust&year=2014&month=12"
        txt = getText(url)
        arr = getOrgID(txt)
        For i = 0 to UBound(arr, 2)
                url = "http://data.eastmoney.com" & arr(0, i)
                arr(0, i) = getTDNum(getText(url)) & " " & url
                WScript.Sleep 1000
        Next
        call SaveToFile(arr)
End Sub

MsgBox "OK"

Function getText(ByVal url)
        Dim http
        Set http = CreateObject ("Microsoft.XMLHTTP")
        http.Open "GET", url, false
        http.Send
        with CreateObject("ADODB.Stream")
                .Mode = 3
                .Type = 1
                .Open
                .Write http.responseBody
                .Position = 0
                .Type = 2
                .Charset = "GB2312"
                getText = .ReadText()
        End with
End Function

Function getOrgID(ByVal txt)
        Dim ar, re, e, i
        ReDim ar(1, 0)
        txt = Split(txt, "信托机构总览")(1)
        Set re = New RegExp
        re.Pattern = "href=""(.+?)"".+?>(.+?)<"
        re.Global = true
        re.IgnoreCase = true
        Set e = re.Execute(txt)
        For i = 0 to e.Count - 1
                ReDim PreServe ar(1, i)
                ar(0, i) = e(i).Submatches(0)
                ar(1, i) = e(i).Submatches(1)
        Next
        getOrgID = ar
End Function

Function getTDNum(s)
        Dim re, m, n
        Set re = New RegExp
        re.Pattern = "tdnumber col.+?tdnumber.+?([\d\.]+)"
        re.Global = true
        re.IgnoreCase = true
        If Not re.Test(s) Then getTDNum = "-" : Exit Function
        For Each m in re.Execute(s)
                n = n + 0 + m.SubMatches(0)
        Next
        getTDNum = n
End Function

Sub SaveToFile(ByVal arr)
        Dim p, oExcel, i, lnk
        p = Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\"))
        Set oExcel = CreateObject("Excel.Application")
        oExcel.Visible = false
        oExcel.WorkBooks.Add
        oExcel.WorkSheets(1).Activate
        For i = 0 to UBound(arr, 2)
                lnk = Split(arr(0, i), " ")(1)
                oExcel.Cells(i+2, 1) = arr(1, i)
                oExcel.Cells(i+2, 2) = Split(arr(0, i), " ")(0)
                oExcel.WorkSheets(1).HyperLinks.Add oExcel.Cells(i+2,1), lnk
        Next
        oExcel.Cells(1, 1) = "信托机构名称"
        oExcel.Cells(1, 2) = "持股市值"
        oExcel.ActiveWorkBook.SaveAs p & "a.xlsx"
        oExcel.WorkBooks.Close
        oExcel.Quit
End Sub
复制代码

caruko

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

uuu888s

回复 2# Eric_Lyly


是的

Eric_Lyly

仅针对这一个网站吗？

Eric_Lyly

仅针对这一个网站吗？