东方财富 龙虎榜数据 地址列表读取数据

YZC51

mmm426 发表于 2015-10-29 09:37
URL = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=LHB&sty=YYHSIU"
    URL  ...

这样看看!

1. Sub YZC()
   
2.     Dim objXML As Object
   
3.     Dim i, j, r
   
4.     Application.ScreenUpdating = False
   
5.     Range("e3:n3000").ClearContents '删除内容
   
6.     For i = 2 To 4
   
7.         j = Cells(i, 4)
   
8.     URL = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=LHB&sty=YYHSIU&code=" & j & "&p=2&ps=50&js=var%20ZlHguMuK=1"
   
9.     Set objXML = CreateObject("Microsoft.XMLHTTP")
   
10.     With objXML
    
11.         .Open "GET", URL, False
    
12.         .send
    
13.         str1 = .responsetext
    
14.      End With
    
15.         Str2 = Split(Split(str1, "([""")(1), """])")(0)
    
16.         Str2 = Replace(Replace(Str2, """,""", Chr(10)), ",", Chr(9))
    
17.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
18.         .SetText Str2
    
19.         .PutInClipboard
    
20.     End With
    
21.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
22.         .SetText Str2
    
23.         .PutInClipboard
    
24.     End With
    
25.     Range("E" & (50 * (i - 2) + 2)).Select
    
26.     ActiveSheet.Paste 'False '无条件覆盖
    
27.     Set objXML = Nothing
    
28.     [C1] = Right(Left(URL, 90), 8) '
    
29.     Application.ScreenUpdating = True
    
30. Next
    
31. End Sub

复制代码

YZC51

以上代码复制语句重复

1. Sub YZC()
   
2.     Dim objXML As Object
   
3.     Dim i, j, r
   
4.     Application.ScreenUpdating = False
   
5.     Range("e3:n3000").ClearContents '删除内容
   
6.     For i = 2 To 4
   
7.         j = Cells(i, 4)
   
8.     URL = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=LHB&sty=YYHSIU&code=" & j & "&p=2&ps=50&js=var%20ZlHguMuK=1"
   
9.     Set objXML = CreateObject("Microsoft.XMLHTTP")
   
10.     With objXML
    
11.         .Open "GET", URL, False
    
12.         .send
    
13.         str1 = .responsetext
    
14.      End With
    
15.         Str2 = Split(Split(str1, "([""")(1), """])")(0)
    
16.         Str2 = Replace(Replace(Str2, """,""", Chr(10)), ",", Chr(9))
    
17.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
18.         .SetText Str2
    
19.         .PutInClipboard
    
20.     End With
    
21.     Range("E" & (50 * (i - 2) + 2)).Select
    
22.     ActiveSheet.Paste 'False '无条件覆盖
    
23.     Set objXML = Nothing
    
24.     [C1] = Right(Left(URL, 90), 8) '
    
25.     Application.ScreenUpdating = True
    
26. Next
    
27. End Sub

复制代码

YZC51

修改

1. Range("E" & (50 * (i - 2) + 2)).Select

复制代码

为

1.     mm = Cells(Rows.Count, 5).End(3).Row
   
2.     Range("E" & mm + 1).Select

复制代码

mmm426

YZC51 发表于 2015-10-29 10:48
以上代码复制语句重复

不行呢
出来的数据就第一个循环 后2个和第一个一样

在SHEET1中把真实地址也加上去
然后地址读取该列的内容  这样能简单点？

kings12333

YZC51 发表于 2015-10-29 11:11
修改

为

感谢大师的帮忙！

YZC51

mmm426 发表于 2015-10-29 13:47
不行呢
出来的数据就第一个循环 后2个和第一个一样

请发几个机构代码上来，我调试下

YZC51

kings12333 发表于 2015-10-29 14:12
感谢大师的帮忙！

不客气！相互学习吗！

mmm426

YZC51 发表于 2015-10-29 14:37
请发几个机构代码上来，我调试下

搞定
赋值时候没读取sheet1的

YZC51

搞定就好！相互学习！谢谢

mmm426

YZC51 发表于 2015-10-29 14:53
搞定就好！相互学习！谢谢

感谢指导

试着用  就是不太稳定 总需要新建表里运行，先用着了