东方财富网天天练

chrispo

just mark~~~

hwwyb

又增加很多内容，非常感谢

onlycxb

11：

1. '东方财富网 > 数据中心 > 资金流向 > 实时资金流向排行
   
2. 
   
3. Sub 全部股票实时资金流向排行()
   
4.     Dim URL As String, P, Num As Long, js As Object, strtext As String
   
5.     '当P取值为空或或p="Net5",p="Net3"时分别取今日，5日和3日数据
   
6.     P = ""
   
7.     URL = "http://nufm.dfcfw.com/EM_Finance2014NumericApplication/JS.aspx/JS.aspx?type=ct&st=(BalFlowMain" & P & ")&sr=-1&p=1&ps=50&js=var%20dy={pages:(pc),data:[(x)]}&token=894050c76af8597a853f5b408b759f5d&cmd=C._AB&sty=DCFFITA&rt=" & Rnd() * 100000000
   
8.     With CreateObject("MSXML2.XMLHTTP")
   
9.         .Open "GET", Replace(URL, "50&js=var%20dy={pages:(pc),data:[(x)]}", "1&js=(pc),(x)"), False
   
10.         .send
    
11.         .Open "GET", Replace(URL, "ps=50", "ps=" & Split(.responsetext, ",")(0)), False
    
12.         .send
    
13.         strtext = .responsetext
    
14.     End With
    
15.     With CreateObject("scriptcontrol")
    
16.         .Language = "javascript"
    
17.         strtext = .eval(strtext & ";var s='';for(x in dy.data){s+=dy.data[x]+'\r'}")
    
18.     End With
    
19.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
20.         .SetText strtext
    
21.         .PutInClipboard
    
22.     End With
    
23.     With ActiveSheet
    
24.         .Cells.Clear
    
25.         .Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
    
26.         .Paste
    
27.         .[a:a].TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=True, Comma:=True
    
28.         .[b:b].NumberFormatLocal = "000000"
    
29.     End With
    
30. End Sub
    

复制代码

onlycxb

73楼问题来源，http://club.excelhome.net/thread-1197941-1-1.html，代码中仅为参照示例，请斧正！见不到73楼代码说明正在审核中

学不完用不尽

一表网尽东方财富。

ym123

onlycxb 发表于 2015-4-4 08:07
第一季度业绩预告，请测试，

您好老师！请教如何获取年终分配预告表格里的代码：[url=http://data.eastmoney.com/bbsj/201412/yjyg/3.html]http://data.eastmoney.com/bbsj/201412/yjyg/3.html[/url]    谢谢！

ym123

同上重复删除

ym123

同上重复删除

hwwyb

麻烦问下，http://data.eastmoney.com/bbsj/201412/szbl.html，这个网页怎么取，用原来的代码取不了，麻烦onlycxb帮忙看看
Sub t()
    Dim html, db, i%, j%, k%, rowx, TD, TR, arrdata(1 To 100000, 1 To 18), P
   
    For P = 1 To 3
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", "http://data.eastmoney.com/bbsj/201412/szbl/szbl/" & P & ".html", False '以取第1页数据为例
        .send
        html.body.innerhtml = .responsetext
    End With

    Set db = html.all.tags("table")
    For i = 0 To db.Length - 1
        If db(i).classname = "tab1" Then
            Set rowx = db(i).Rows
            For Each TR In rowx
                j = j + 1
                k = 0
                For Each TD In TR.Cells
                     k = k + 1
                If j > 1 Then arrdata(j, k) = TD.innertext
                Next TD
            Next TR
        End If
    Next i
    Set html = Nothing
    Set db = Nothing
    Set rowx = Nothing
    Next P
    Cells.Clear
    [a1].Resize(j, 18) = arrdata
    For i = 3 To Sheet5.[a65535].End(xlUp).Row
   
   
    If Sheet5.Cells(i, 1) = "序号" Then Sheet5.Rows(i).Delete
         
    Next

   
    i = Sheet5.[a65535].End(xlUp).Row
    Worksheets("Sheet5").Range("A2:M" & i).Copy _
    Destination:=Worksheets("Sheet1").Range("A3")

End Sub

hwwyb

根据楼主的代码，我修改如下，已经可以了，谢谢！

Sub test()
    Dim strJs, P, arr, i
    Cells.ClearContents
    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=SR&sty=SZBL&fd=2014-12-31&st=2&sr=-1&p=1&ps=1&js=(pc),(x)", False
        .send
        P = Split(.responsetext, ",")(0)
        .Open "GET", "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=SR&sty=SZBL&fd=2014-12-31&st=2&sr=-1&p=1&ps=" & P & "&js=var%20a={pages:(pc),data:[(x)]}", False
        .send
        
         
        strJs = .responsetext & ";var b=a.data;var s=''; for(x in b){s+=b[x]+'\r';}"
    End With
    With CreateObject("MSScriptControl.ScriptControl")
        .Language = "javascript"
        strJs = .Eval(strJs)
    End With
    arr = Split(strJs, vbCr)
    With ActiveSheet
        .[a2].Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
       .[a:a].TextToColumns Destination:=Range("A1"), Comma:=True
    End With
     Cells(1, 1).Resize(1, UBound(arr) + 1) = Array("股票代码", "股票简称", "利润分配 ", "送转比例", "现金分红", "每股收益(元)", "每股未分配利润(元)", "每股未分配利润(元)", "上期每股未分配利润(元)  ", "上期每股资本公积金(元)", "股权登记日", "公告日期")
     i = Sheet5.[a65535].End(xlUp).Row
    Worksheets("Sheet5").Range("A2:M" & i).Copy _
    Destination:=Worksheets("Sheet1").Range("B3")
End Sub