请老师写个采集股票数据的代码

lixjun

原帖由 xmyjk 于 2011-4-2 16:16 发表
估计是比较规律，可能下午时候，就开始不能直接访问，采取防盗链的转向控制。

晚上再试看看。

还好那个上市、深市和创业版的还能用。

好的！回头再试试看。

xmyjk

现在又可以用了，估计是收市以后就可以用了。你试看看。

lixjun

原帖由 xmyjk 于 2011-4-2 17:20 发表
现在又可以用了，估计是收市以后就可以用了。你试看看。

确实能用了！！这个脚本好！运行时cpu没到100%，其他程序也不受影响。页面跟超牛的脚本一样整洁，多谢老师！！辛苦了！！

冰血情人

顶...................................

lixjun

原帖由 xmyjk 于 2011-4-2 17:20 发表
现在又可以用了，估计是收市以后就可以用了。你试看看。

最近一直研究老师的脚本。麻烦老师给讲讲“散户大家庭”那个脚本里的这个“arr”是什么意思和使用规范。
ReDim arr(UBound(tmp) \ 38, 37)
    For i = 1 To UBound(tmp)
       arr((i - 1) \ 38, (i - 1) Mod 38) = Split(Split(tmp(i), ">")(1), "</")(0)

尤其画红线部分不太明白。另外按照这个脚本，自己做了个XML提取的脚本。可是由于XML文件格式不太统一，造成较多错行。麻烦老师给看看，多谢了！！


决策数据.rar (80.05 KB, 下载次数: 104)

2011-4-13 11:33 上传

点击文件名下载附件

xmyjk

原帖由 lixjun 于 2011-4-13 11:33 发表


最近一直研究老师的脚本。麻烦老师给讲讲“散户大家庭”那个脚本里的这个“arr”是什么意思和使用规范。
ReDim arr(UBound(tmp) \ 38, 37)
    For i = 1 To UBound(tmp)
       arr((i - 1) \ 38, (i - 1) M ...

1. Sub test()
   
2.     Dim tmp() As String, i As Long, arr() As String, d As String, p As Integer, n As Long, xmlhttp As Object, JC As Worksheet, UserRange As Range, TMP1() As String
   
3.     Dim J As Long
   
4.       
   
5.     On Error Resume Next
   
6.     If Sheets("机构评级汇总") Is Nothing Then
   
7.     Set JC = Sheets.Add(AFTER:=Worksheets("起始页"))
   
8.        JC.Name = "机构评级汇总"
   
9.     Else
   
10.      Set JC = Sheets("机构评级汇总")
    
11.         Worksheets("机构评级汇总").Activate
    
12.         Cells.Select
    
13.         Selection.ClearContents
    
14.     End If
    
15.    
    
16.     [a1:k1] = Split("代码,评级日期,机构数,最新评级,上月机构数,上月评级,调整幅度,2010A,2011E,2012E,2013E", ",")
    
17.      FILE_PATH = ThisWorkbook.Path & "" & "机构评级汇总.xml"
    
18.      
    
19.     Application.ScreenUpdating = False
    
20.     Open FILE_PATH For Input As #1
    
21.     tmp() = Split(Split(Split(StrConv(InputB(LOF(1), 1), vbUnicode), "<lines>")(1), "</lines>")(0), "</line>")
    
22.     Close #1
    
23.    
    
24.     For i = 0 To UBound(tmp)
    
25.      TMP1() = Split(tmp(i), "</")
    
26.       For J = 0 To UBound(TMP1)
    
27.          arr() = Split(TMP1(J), ">")
    
28.          TMP1(J) = arr(UBound(arr))
    
29.       Erase arr
    
30.       Next
    
31.      n = [a65536].End(xlUp).Row + 1
    
32.      Cells(n, 1).Resize(1, UBound(TMP1) + 1) = TMP1
    
33.      Erase TMP1
    
34.     Next
    
35.    
    
36.     Erase tmp
    
37.     Set xmlhttp = Nothing
    
38.     [a:k].Columns.AutoFit
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "Ok"
    
41. End Sub
    

复制代码

lixjun

这么快就改好了，谢谢老师了！！又够我研究一阵子的！

xmyjk

原帖由 lixjun 于 2011-4-13 13:34 发表
这么快就改好了，谢谢老师了！！又够我研究一阵子的！

1. Option Explicit
   
2. Sub test()
   
3.     Dim tmp() As String, i As Long, n As Long, JC As Worksheet, FILE_PATH As String
   
4.     Dim J As Integer
   
5.       
   
6.     On Error Resume Next
   
7.     If Sheets("机构评级汇总") Is Nothing Then
   
8.     Set JC = Sheets.Add(AFTER:=Worksheets("起始页"))
   
9.        JC.Name = "机构评级汇总"
   
10.     Else
    
11.      Set JC = Sheets("机构评级汇总")
    
12.         Worksheets("机构评级汇总").Activate
    
13.         Cells.Select
    
14.         Selection.ClearContents
    
15.     End If
    
16.    
    
17.     [a1:k1] = Split("代码,评级日期,机构数,最新评级,上月机构数,上月评级,调整幅度,2010A,2011E,2012E,2013E", ",")
    
18.      FILE_PATH = ThisWorkbook.Path & "" & "机构评级汇总.xml"
    
19.      
    
20.     Application.ScreenUpdating = False
    
21.     Open FILE_PATH For Input As #1
    
22.     tmp() = Split(Split(Split(StrConv(InputB(LOF(1), 1), vbUnicode), "<lines>")(1), "</lines>")(0), "</line>")
    
23.     Close #1
    
24.    
    
25.     For i = 0 To UBound(tmp)
    
26.      n = [a65536].End(xlUp).Row + 1
    
27.      Cells(n, 1) = Split(Split(tmp(i), "<stk>")(1), "</stk>")(0)
    
28.       For J = 3 To 12
    
29.         Cells(n, J - 1) = Split(Split(Split(tmp(i), "<dat col=""" & J & """")(1), "</dat>")(0), ">")(1)
    
30.       Next
    
31.     Next
    
32.         
    
33.     Erase tmp
    
34.    
    
35.     [a:k].Columns.AutoFit
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "Ok"
    
38. End Sub

复制代码

lixjun

这个文件是炒股软件大智慧的数据。对比了一下，第二次做的完全正确。原数据缺数的列也都对应上了。麻烦老师了！！

EH2003

二话不说，回了在说