|
|
修改表头整理完毕，并添加代码注释，你看看如何，表见附件，代码如下。
原帖由 ck1668 于 2011-4-17 12:49 发表 
好的。谢谢你！
自动排序的代码：- Dim x As Boolean, m As Single '设置计数器和逻辑判断，定义区域变量，可保存在内存中直至工作薄关闭
- Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
- Dim n As Long, nn As Long
- n = [a65536].End(xlUp).Row '获取行数
- nn = [n65536].End(xlUp).Row
- x = m Mod 2 '点击两次，重新每次的设置逻辑切换，仅仅排序后才改变逻辑
- If x = False Then '降序逻辑操作
- Select Case Target.Address
- Case "$A$1"
- Range("a1:m" & n).Sort [a1], xlDescending, , , , , , 1: m = m + 1
- Case "$E$1"
- Range("a1:m" & n).Sort [e1], xlDescending, , , , , , 1: m = m + 1
- Case "$F$1"
- Range("a1:m" & n).Sort [f1], xlDescending, , , , , , 1: m = m + 1
- Case "$G$1"
- Range("a1:m" & n).Sort [g1], xlDescending, , , , , , 1: m = m + 1
- Case "$H$1"
- Range("a1:m" & n).Sort [h1], xlDescending, , , , , , 1: m = m + 1
- Case "$I$1"
- Range("a1:m" & n).Sort [i1], xlDescending, , , , , , 1: m = m + 1
- Case "$J$1"
- Range("a1:m" & n).Sort [j1], xlDescending, , , , , , 1: m = m + 1
- Case "$K$1"
- Range("a1:m" & n).Sort [k1], xlDescending, , , , , , 1: m = m + 1
- Case "$L$1"
- Range("a1:m" & n).Sort [l1], xlDescending, , , , , , 1: m = m + 1
- Case "$M$1"
- Range("a1:m" & n).Sort [m1], xlDescending, , , , , , 1: m = m + 1
- Case "$N$1"
- Range("n1:z" & nn).Sort [n1], xlDescending, , , , , , 1: m = m + 1
- Case Else
- DoEvents
- End Select
- ElseIf x = True Then '升序逻辑操作
- Select Case Target.Address
- Case "$A$1"
- Range("a1:m" & n).Sort [a1], xlAscending, , , , , , 1: m = m + 1
- Case "$E$1"
- Range("a1:m" & n).Sort [e1], xlAscending, , , , , , 1: m = m + 1
- Case "$F$1"
- Range("a1:m" & n).Sort [f1], xlAscending, , , , , , 1: m = m + 1
- Case "$G$1"
- Range("a1:m" & n).Sort [g1], xlAscending, , , , , , 1: m = m + 1
- Case "$H$1"
- Range("a1:m" & n).Sort [h1], xlAscending, , , , , , 1: m = m + 1
- Case "$I$1"
- Range("a1:m" & n).Sort [i1], xlAscending, , , , , , 1: m = m + 1
- Case "$J$1"
- Range("a1:m" & n).Sort [j1], xlAscending, , , , , , 1: m = m + 1
- Case "$K$1"
- Range("a1:m" & n).Sort [k1], xlAscending, , , , , , 1: m = m + 1
- Case "$L$1"
- Range("a1:m" & n).Sort [l1], xlAscending, , , , , , 1: m = m + 1
- Case "$M$1"
- Range("a1:m" & n).Sort [m1], xlAscending, , , , , , 1: m = m + 1
- Case "$N$1"
- Range("n1:z" & nn).Sort [n1], xlAscending, , , , , , 1: m = m + 1
- Case Else
- DoEvents
- End Select
-
- End If
- End Sub
- Option Explicit
- Sub test()
- 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()
-
- Application.ScreenUpdating = False
-
- Nm = 0
-
- On Error Resume Next
-
- Td = Format(Date, "yyyymmdd") '记录当日日期
- Set JC = Sheets(Td)
- If Not (JC Is Nothing) Then '当日表存在则清空数据
- JC.Activate
- Cells.Clear
- Else
- Set JC = Sheets.Add(AFTER:=Worksheets("起始页")) '单日表不存在新建
- JC.Name = Td
- JC.Activate
- End If
-
- [a1:m1] = Split("代码,2B,3c,名称,最新价,涨跌幅,流入(万),流出(万),净流入(万),净流入占比,大单净流入(万),中单净流入(万),小单净流入(万)", ",") '当日表表头
-
- Set xmlhttp = CreateObject("Microsoft.XMLHTTP") '调用XMLHTTP
- With xmlhttp
- .Open "get", "http://data.eastmoney.com/zjlx/data_detail.js", False
- .send
- tmp = Split(Split(Split(Replace(StrConv(.responsebody, vbUnicode, &H804), """,""", ","), "=[""")(1), """];")(0), ",")
- End With
-
- ReDim arr(UBound(tmp) \ 13, 12) '整理XMLHTTP获取的数据
- For i = 0 To UBound(tmp)
- arr(i \ 13, i Mod 13) = tmp(i)
- Next
-
- [a2].Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr '将数据导入当日表内并设置格式调整列宽
- [a:m].Columns.AutoFit
- Columns("b:c").ColumnWidth = 0
- Columns("a").NumberFormat = "000000"
- Columns("h").NumberFormat = "-0.00"
- Columns("f").NumberFormat = "0\.00%"
- Columns("j").NumberFormat = "0\.00%"
-
- Erase tmp '释放各变量
- Erase arr
- Set xmlhttp = Nothing
-
- sName = "统计"
- Set ws = Sheets(sName)
- If Not (ws Is Nothing) Then '查找统计表，如果存在则删除
- Application.DisplayAlerts = False
- ws.Delete
- Application.DisplayAlerts = True
- End If
-
- Set ws = Sheets.Add(AFTER:=Worksheets(Worksheets.Count)) '建立新统计表
- ws.Name = sName
- ws.Activate
-
- Set D = CreateObject("scripting.dictionary") '建立字典
- Set DS = CreateObject("scripting.dictionary")
-
- For i = 1 To Worksheets.Count '历遍工作薄各表
- If Worksheets(i).Name <> sName And Worksheets(i).Name <> "起始页" Then '提取非"起始页"和"统计"的表的数据
- n = Worksheets(i).[a65536].End(3).Row
- tmp1 = Worksheets(i).Range("a2:m" & n).Value '将数据导提取入数组
- ReDim Preserve ARR2(1 To Application.Max(UBound(tmp1), D.Count) + 1, 1 To (Worksheets.Count - 2) * 2) '设置结果数组维数
-
- For j = 1 To UBound(tmp1) '利用字典提取需要的信息
- If Not (D.exists(tmp1(j, 1))) Then '如果字典关键字不存在，则新建关键字并写入关键字编号
- Nm = Nm + 1
- D(tmp1(j, 1)) = Nm
- DS(tmp1(j, 4)) = Nm
- ARR2(Nm + 1, i - 1) = tmp1(j, 9) '利用关键字编号将提取数组转入结果数组
- ARR2(Nm + 1, i - 1 + Worksheets.Count - 2) = tmp1(j, 11)
- Else '如关键字已存在，使用关键字的变化从提取数组提取数据到结果数组
- ARR2(D(tmp1(j, 1)) + 1, i - 1) = tmp1(j, 9)
- ARR2(D(tmp1(j, 1)) + 1, i - 1 + Worksheets.Count - 2) = tmp1(j, 11)
- End If
- Next
-
- ARR2(1, i - 1) = Worksheets(i).Name & "净流入" '创建结果数组数据日期和关键字表头
- ARR2(1, i - 1 + Worksheets.Count - 2) = Worksheets(i).Name & "大单净流入"
-
- End If
-
- Erase tmp1 '释放提取数组变量
- Next
-
- k = D.keys '导出股票代码
- t = D.items '导出内置序号
- y = DS.keys '导出股票名称
- [n1].Resize(1, 2) = Split("代码,名称", ",") '建表头
- [n2].Resize(D.Count, 1) = Application.Transpose(k) '将导入内容填入单元格
- [o2].Resize(DS.Count, 1) = Application.Transpose(y)
- [p1].Resize(UBound(ARR2, 1), UBound(ARR2, 2)) = ARR2
- n = [n65536].End(3).Row ' 调整格式
- Columns("n").NumberFormat = "000000"
- Range(Cells(1, 14), Cells(1, 14 + 2 + UBound(ARR2, 2))).WrapText = True
- Range(Cells(2, 14), Cells(n, 14 + 2 + UBound(ARR2, 2))).Columns.AutoFit
- [a:m].ColumnWidth = 0
- Erase ARR2 '释放结果数组
- Set D = Nothing
- Set DS = Nothing
- Application.ScreenUpdating = True
- MsgBox "Ok"
- End Sub
[ 本帖最后由 xmyjk 于 2011-4-17 15:00 编辑 ] |
|
楼主: lzh8221
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-4-17 12:49
