请高手帮忙： 多个网页数据导入excel

ck1668

好的。谢谢你！

xmyjk

原帖由 ck1668 于 2011-4-17 12:49 发表
好的。谢谢你！

自动排序的代码：

1. Dim x As Boolean, m As Single '设置计数器和逻辑判断，定义区域变量，可保存在内存中直至工作薄关闭
   
2. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
3. 
   
4. Dim n As Long, nn As Long
   
5. n = [a65536].End(xlUp).Row '获取行数
   
6. nn = [n65536].End(xlUp).Row
   
7. 
   
8. x = m Mod 2 '点击两次，重新每次的设置逻辑切换，仅仅排序后才改变逻辑
   
9. 
   
10. If x = False Then '降序逻辑操作
    
11. Select Case Target.Address
    
12.   Case "$A$1"
    
13.     Range("a1:m" & n).Sort [a1], xlDescending, , , , , , 1: m = m + 1
    
14.   Case "$E$1"
    
15.     Range("a1:m" & n).Sort [e1], xlDescending, , , , , , 1: m = m + 1
    
16.   Case "$F$1"
    
17.     Range("a1:m" & n).Sort [f1], xlDescending, , , , , , 1: m = m + 1
    
18.   Case "$G$1"
    
19.     Range("a1:m" & n).Sort [g1], xlDescending, , , , , , 1: m = m + 1
    
20.   Case "$H$1"
    
21.     Range("a1:m" & n).Sort [h1], xlDescending, , , , , , 1: m = m + 1
    
22.   Case "$I$1"
    
23.     Range("a1:m" & n).Sort [i1], xlDescending, , , , , , 1: m = m + 1
    
24.   Case "$J$1"
    
25.     Range("a1:m" & n).Sort [j1], xlDescending, , , , , , 1: m = m + 1
    
26.   Case "$K$1"
    
27.     Range("a1:m" & n).Sort [k1], xlDescending, , , , , , 1: m = m + 1
    
28.   Case "$L$1"
    
29.     Range("a1:m" & n).Sort [l1], xlDescending, , , , , , 1: m = m + 1
    
30.   Case "$M$1"
    
31.     Range("a1:m" & n).Sort [m1], xlDescending, , , , , , 1: m = m + 1
    
32.   Case "$N$1"
    
33.     Range("n1:z" & nn).Sort [n1], xlDescending, , , , , , 1: m = m + 1
    
34.   Case Else
    
35.     DoEvents
    
36. End Select
    
37. 
    
38. ElseIf x = True Then '升序逻辑操作
    
39. Select Case Target.Address
    
40.   Case "$A$1"
    
41.     Range("a1:m" & n).Sort [a1], xlAscending, , , , , , 1: m = m + 1
    
42.   Case "$E$1"
    
43.     Range("a1:m" & n).Sort [e1], xlAscending, , , , , , 1: m = m + 1
    
44.   Case "$F$1"
    
45.     Range("a1:m" & n).Sort [f1], xlAscending, , , , , , 1: m = m + 1
    
46.   Case "$G$1"
    
47.     Range("a1:m" & n).Sort [g1], xlAscending, , , , , , 1: m = m + 1
    
48.   Case "$H$1"
    
49.     Range("a1:m" & n).Sort [h1], xlAscending, , , , , , 1: m = m + 1
    
50.   Case "$I$1"
    
51.     Range("a1:m" & n).Sort [i1], xlAscending, , , , , , 1: m = m + 1
    
52.   Case "$J$1"
    
53.     Range("a1:m" & n).Sort [j1], xlAscending, , , , , , 1: m = m + 1
    
54.   Case "$K$1"
    
55.     Range("a1:m" & n).Sort [k1], xlAscending, , , , , , 1: m = m + 1
    
56.   Case "$L$1"
    
57.     Range("a1:m" & n).Sort [l1], xlAscending, , , , , , 1: m = m + 1
    
58.   Case "$M$1"
    
59.     Range("a1:m" & n).Sort [m1], xlAscending, , , , , , 1: m = m + 1
    
60.   Case "$N$1"
    
61.     Range("n1:z" & nn).Sort [n1], xlAscending, , , , , , 1: m = m + 1
    
62.   Case Else
    
63.     DoEvents
    
64. End Select
    
65. 
    
66. End If
    
67. 
    
68. End Sub
    

复制代码

获取数据并统计的代码。

1. Option Explicit
   
2. Sub test()
   
3.     Dim tmp() As String, i As Integer, arr(), xmlhttp As Object, n As Long, JC As Worksheet, Td As String, ws As Worksheet, sName As String, D, DS, j As Long, Nm As Long, k, t, y, ARR2(), tmp1()
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.    
   
7.     Nm = 0
   
8.    
   
9.     On Error Resume Next
   
10.    
    
11.     Td = Format(Date, "yyyymmdd") '记录当日日期
    
12.     Set JC = Sheets(Td)
    
13.     If Not (JC Is Nothing) Then '当日表存在则清空数据
    
14.        JC.Activate
    
15.        Cells.Clear
    
16.     Else
    
17.        Set JC = Sheets.Add(AFTER:=Worksheets("起始页")) '单日表不存在新建
    
18.        JC.Name = Td
    
19.        JC.Activate
    
20.     End If
    
21.    
    
22.     [a1:m1] = Split("代码,2B,3c,名称,最新价,涨跌幅,流入(万),流出(万),净流入(万),净流入占比,大单净流入(万),中单净流入(万),小单净流入(万)", ",") '当日表表头
    
23.    
    
24.     Set xmlhttp = CreateObject("Microsoft.XMLHTTP") '调用XMLHTTP
    
25.     With xmlhttp
    
26.         .Open "get", "http://data.eastmoney.com/zjlx/data_detail.js", False
    
27.         .send
    
28.        tmp = Split(Split(Split(Replace(StrConv(.responsebody, vbUnicode, &H804), """,""", ","), "=[""")(1), """];")(0), ",")
    
29.     End With
    
30.    
    
31.     ReDim arr(UBound(tmp) \ 13, 12) '整理XMLHTTP获取的数据
    
32.     For i = 0 To UBound(tmp)
    
33.         arr(i \ 13, i Mod 13) = tmp(i)
    
34.     Next
    
35.    
    
36.     [a2].Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr '将数据导入当日表内并设置格式调整列宽
    
37.     [a:m].Columns.AutoFit
    
38.     Columns("b:c").ColumnWidth = 0
    
39.     Columns("a").NumberFormat = "000000"
    
40.     Columns("h").NumberFormat = "-0.00"
    
41.     Columns("f").NumberFormat = "0\.00%"
    
42.     Columns("j").NumberFormat = "0\.00%"
    
43.         
    
44.     Erase tmp   '释放各变量
    
45.     Erase arr
    
46.     Set xmlhttp = Nothing
    
47.    
    
48.     sName = "统计"
    
49.     Set ws = Sheets(sName)
    
50.     If Not (ws Is Nothing) Then  '查找统计表，如果存在则删除
    
51.         Application.DisplayAlerts = False
    
52.           ws.Delete
    
53.         Application.DisplayAlerts = True
    
54.     End If
    
55.    
    
56.     Set ws = Sheets.Add(AFTER:=Worksheets(Worksheets.Count)) '建立新统计表
    
57.     ws.Name = sName
    
58.     ws.Activate
    
59.    
    
60.     Set D = CreateObject("scripting.dictionary") '建立字典
    
61.     Set DS = CreateObject("scripting.dictionary")
    
62.       
    
63.     For i = 1 To Worksheets.Count '历遍工作薄各表
    
64.     If Worksheets(i).Name <> sName And Worksheets(i).Name <> "起始页" Then '提取非"起始页"和"统计"的表的数据
    
65.       n = Worksheets(i).[a65536].End(3).Row
    
66.       tmp1 = Worksheets(i).Range("a2:m" & n).Value '将数据导提取入数组
    
67.       ReDim Preserve ARR2(1 To Application.Max(UBound(tmp1), D.Count) + 1, 1 To (Worksheets.Count - 2) * 2) '设置结果数组维数
    
68.       
    
69.       For j = 1 To UBound(tmp1) '利用字典提取需要的信息
    
70.          If Not (D.exists(tmp1(j, 1))) Then '如果字典关键字不存在，则新建关键字并写入关键字编号
    
71.            Nm = Nm + 1
    
72.            D(tmp1(j, 1)) = Nm
    
73.            DS(tmp1(j, 4)) = Nm
    
74.            ARR2(Nm + 1, i - 1) = tmp1(j, 9) '利用关键字编号将提取数组转入结果数组
    
75.            ARR2(Nm + 1, i - 1 + Worksheets.Count - 2) = tmp1(j, 11)
    
76.          Else   '如关键字已存在，使用关键字的变化从提取数组提取数据到结果数组
    
77.            ARR2(D(tmp1(j, 1)) + 1, i - 1) = tmp1(j, 9)
    
78.            ARR2(D(tmp1(j, 1)) + 1, i - 1 + Worksheets.Count - 2) = tmp1(j, 11)
    
79.          End If
    
80.       Next
    
81.    
    
82.       ARR2(1, i - 1) = Worksheets(i).Name & "净流入" '创建结果数组数据日期和关键字表头
    
83.       ARR2(1, i - 1 + Worksheets.Count - 2) = Worksheets(i).Name & "大单净流入"
    
84.             
    
85.     End If
    
86.    
    
87.     Erase tmp1 '释放提取数组变量
    
88.     Next
    
89.   
    
90.   k = D.keys '导出股票代码
    
91.   t = D.items '导出内置序号
    
92.   y = DS.keys '导出股票名称
    
93. 
    
94. [n1].Resize(1, 2) = Split("代码,名称", ",") '建表头
    
95. [n2].Resize(D.Count, 1) = Application.Transpose(k) '将导入内容填入单元格
    
96. [o2].Resize(DS.Count, 1) = Application.Transpose(y)
    
97. [p1].Resize(UBound(ARR2, 1), UBound(ARR2, 2)) = ARR2
    
98. 
    
99. n = [n65536].End(3).Row ' 调整格式
    
100. Columns("n").NumberFormat = "000000"
     
101. Range(Cells(1, 14), Cells(1, 14 + 2 + UBound(ARR2, 2))).WrapText = True
     
102. Range(Cells(2, 14), Cells(n, 14 + 2 + UBound(ARR2, 2))).Columns.AutoFit
     
103. [a:m].ColumnWidth = 0
     
104. 
     
105. Erase ARR2 '释放结果数组
     
106. Set D = Nothing
     
107. Set DS = Nothing
     
108. 
     
109. Application.ScreenUpdating = True
     
110. 
     
111. MsgBox "Ok"
     
112. 
     
113. End Sub
     

复制代码

[ 本帖最后由 xmyjk 于 2011-4-17 15:00 编辑 ]

ck1668

表格做的非常好，代码讲的非常仔细，象你这样既肯帮忙，又细心指教的老师，真是难得。
我相信不单止我非常感谢你的这次帮忙，令我炒股更方便，其他想学代码的兄弟朋友应该也是一个非常不错的好机会，再次感谢！

ck1668

老师，麻烦你帮我再加一个中单的统计，因刚大致看了一下，发现有的大单与中单相差比较大。譬如：深长城，净流入有1228.55，而大单只有52.94，开始我以为剩下的1175.61会是中单小单各一半，但不是。

代码        名称        净流入(万)        大单净流入(万)      中单净流入(万)        小单净流入(万)
000042        深 长 城        1228.55        52.94                     938.64            236.97

还有一点：老师，请看附件，统计表里可不可以按时间先后排？即：20110415的在最左边，挨着20110415的右边20110416，挨着20110416的右边20110417，这样好像比较习惯一点。

股票终结版.zip (522.66 KB, 下载次数: 15)

2011-4-17 16:39 上传

点击文件名下载附件

[ 本帖最后由 ck1668 于 2011-4-17 16:39 编辑 ]

xmyjk

原帖由 ck1668 于 2011-4-17 16:15 发表
老师，麻烦你帮我再加一个中单的统计，因刚大致看了一下，发现有的大单与中单相差比较大。譬如：深长城，净流入有1228.55，而大单只有52.94，开始我以为剩下的1175.61会是中单小单各一半，但不是。

代码        名称        净流 ...

看看这个，增加中单后，该排序方式我择期再看看，这个要改动我整个逻辑顺序，工程很大。。

ck1668

老师，你看看能不能改，如果不好改，工程很大就算了，我凑合着看就行，时间长了会习惯的。谢谢！

ck1668

还想你帮忙改一下每天的数据，代码那一栏，能不能从小排到大，即：A2是000001，A3是000002 ？因现在都是9字头的排在前面，而9字头的是B股，谢谢！

xmyjk

原帖由 ck1668 于 2011-4-17 17:23 发表
还想你帮忙改一下每天的数据，代码那一栏，能不能从小排到大，即：A2是000001，A3是000002 ？因现在都是9字头的排在前面，而9字头的是B股，谢谢！

有做自动排序，你点A1,再点A2，再回来点A1看看，就自动排序过来了。

ck1668

好的，我点下算了，谢谢！

xmyjk

原帖由 ck1668 于 2011-4-17 17:11 发表
老师，你看看能不能改，如果不好改，工程很大就算了，我凑合着看就行，时间长了会习惯的。谢谢！

时间顺序也调整过来了，你看看