|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
完工,应该能符合你这两点的要求,仔细核对看看
原帖由 ck1668 于 2011-4-16 13:33 发表
对不起,刚才有点事出去了。
1,这个方法也可以习惯,但如果能少点一个A3就更方便,譬如:点A1排序后,再点A2,然后再点A1就会是新的排序方式 了。当然,如果不能省的话也没关系,用多一阵子也就一样会习惯的。
2, ...
很久没写汇总的代码了,绕了些弯路,总算是完工了
排序的也调整好了,按你的方式。
你试看看吧。
另外超出五天的工作表你手动删除就是,就不再弄了。- 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, arr1() As Single, k, t, y
- 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")
- 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)
- 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("e:f").Replace What:="-", Replacement:="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")
- Dim tmp1
- 'Debug.Print Worksheets.Count
- For i = 1 To Worksheets.Count
- If Worksheets(i).Name <> sName And Worksheets(i).Name <> "起始页" Then
- 'Worksheets(i).Activate
- n = Worksheets(i).[a65536].End(3).Row
- tmp1 = Worksheets(i).Range("a2:m" & n).Value
- ReDim Preserve arr1(1 To Application.Max(UBound(tmp1), D.Count), 1 To 6)
- For j = 1 To UBound(tmp1)
- If Not (D.exists(tmp1(j, 1))) Then
- Nm = Nm + 1
- D(tmp1(j, 1)) = Nm: arr1(Nm, 1) = tmp1(j, 7): arr1(Nm, 2) = tmp1(j, 8): arr1(Nm, 3) = tmp1(j, 9): arr1(Nm, 4) = tmp1(j, 11): arr1(Nm, 5) = tmp1(j, 12): arr1(Nm, 6) = tmp1(j, 13)
- DS(tmp1(j, 4)) = Nm
- Else
- arr1(D(tmp1(j, 1)), 1) = arr1(D(tmp1(j, 1)), 1) + tmp1(j, 7): arr1(D(tmp1(j, 1)), 2) = arr1(D(tmp1(j, 1)), 2) + tmp1(j, 8): arr1(D(tmp1(j, 1)), 3) = arr1(D(tmp1(j, 1)), 3) + tmp1(j, 9): arr1(D(tmp1(j, 1)), 4) = arr1(D(tmp1(j, 1)), 4) + tmp1(j, 11): arr1(D(tmp1(j, 1)), 5) = arr1(D(tmp1(j, 1)), 5) + tmp1(j, 12): arr1(D(tmp1(j, 1)), 6) = arr1(D(tmp1(j, 1)), 6) + tmp1(j, 13)
- End If
- Next
- End If
- Erase tmp1
- Next
-
- k = D.keys
- t = D.items
- y = DS.keys
- [a2].Resize(D.Count, 1) = Application.Transpose(k)
- [b2].Resize(DS.Count, 1) = Application.Transpose(y)
- [a1].Resize(1, 9) = Split("代码,名称,流入(万),流出(万),净流入(万),大单净流入(万),中单净流入(万),小单净流入(万),净流入占比,", ",")
- [c2].Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
- [a:i].Columns.AutoFit
- Columns("a").NumberFormat = "000000"
- Columns("c:h").NumberFormat = "0.00"
- Columns("d").NumberFormat = "-0.00"
- Erase arr1
- Set D = Nothing
- Set DS = Nothing
- n = [a65536].End(3).Row
- Range("i2:i" & n).Formula = "=E2/(C2+D2)"
- Columns("I").NumberFormat = "0.00%"
- MsgBox "Ok"
- End Sub
复制代码
[ 本帖最后由 xmyjk 于 2011-4-16 15:41 编辑 ] |
|