[已解决]怎样用VBA实现统计重复次数

manz

通过表一和表二的数据，用VBA统计重复的次数和提取数据！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-8-4 14:44

请看附件。

跳转到最佳答案楼层

pengyx

如按秒更新，数据量为4小时*每小时3600秒*2000支股票＝28800000条数据，至少也有10000000条数据吧？excel　耍不转

vbyou129

先作个标志，有时间再做

manz

pengyx 发表于 2015-8-2 23:46
如按秒更新，数据量为4小时*每小时3600秒*2000支股票＝28800000条数据，至少也有10000000条数据吧？excel　 ...

谢谢您的解答，其实没有那么多，是每十五分钟更新一次，并且并不是所有的股票都出现的。

manz

vbyou129 发表于 2015-8-3 08:39
先作个标志，有时间再做

谢谢您的解答，我等待您的答案！

grf1973

原代码基本可用。小改了一下，用数组储存显示结果后一次性输出。

1. Sub test()
   
2.     Application.DisplayAlerts = False
   
3.     Application.ScreenUpdating = False
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     Set dic1 = CreateObject("scripting.dictionary")
   
6.     Set dic2 = CreateObject("scripting.dictionary")
   
7.    
   
8.     Rng = Sheets(1).[a1].CurrentRegion
   
9.    
   
10.     For c = UBound(Rng, 2) - 3 To 1 Step -4
    
11.       For r = UBound(Rng) To 2 Step -1
    
12.          y = Rng(r, c + 1) & "," & Rng(r, c + 2)
    
13.          dic(y) = ""
    
14.          yy = y & "," & Rng(r, c + 3)
    
15.          dic1(yy) = dic1(yy) + 1
    
16.          dic2(yy) = dic2(yy) & Rng(r, c) & ","
    
17.       Next r
    
18.     Next c
    
19.    
    
20.    
    
21.     orng = Sheets(2).[a1].CurrentRegion
    
22.     Sheets(2).[a1].CurrentRegion.Replace " 点评", ""
    
23.     Rng = Sheets(2).[a1].CurrentRegion
    
24.     Sheets(2).[a1].CurrentRegion = orng
    
25.    
    
26.     For r = 3 To UBound(Rng)
    
27.        y = Rng(r, 2) & "," & Rng(r, 3)
    
28.        dic(y) = ""
    
29.         
    
30.       For c = 6 To UBound(Rng, 2)
    
31.          yy = y & "," & Rng(1, c) & Rng(2, c)
    
32.          dic1(yy) = Rng(r, c)
    
33.       Next c
    
34.     Next r
    
35.    
    
36.    
    
37.     Sheets(4).Select
    
38.     Rows("2:1048576").ClearContents
    
39.     otrng = Range("a1:ah1")
    
40.     Range("a1:ah1").Replace "重复次数", ""
    
41.     Range("a1:ah1").Replace "的时间", ""
    
42.     trng = Range("a1:ah1")
    
43.     Range("a1:ah1") = otrng
    
44.     k = dic.keys
    
45.     Dim brr(1 To 10000, 1 To 34)    '结果数组
    
46.     tr = 1
    
47.    
    
48.     For i = 0 To dic.Count - 1     '表一内容：重复次数+重复时间
    
49.         maxtr = 1
    
50.         brr(tr, 1) = Split(k(i), ",")(0)    '代码
    
51.         brr(tr, 2) = Split(k(i), ",")(1)       '名称
    
52.         For c = 3 To 20 Step 2
    
53.            yy = k(i) & "," & trng(1, c)
    
54.              brr(tr, c) = dic1(yy)     '重复次数
    
55.              w = Split(dic2(yy), ",")
    
56.              If dic1(yy) = 1 Then       '重复时间，按重复次数逐行往下填充
    
57.                 brr(tr, c + 1) = w(0)
    
58.              Else
    
59.                 If dic1(yy) > maxtr Then maxtr = dic1(yy)
    
60.                 For ii = 0 To UBound(w)
    
61.                     brr(tr + ii, c + 1) = w(ii)
    
62.                 Next ii
    
63.             End If
    
64.         Next c
    
65.         For c = 21 To 34          '表2内容
    
66.            yy = k(i) & "," & trng(1, c)
    
67.            brr(tr, c) = dic1(yy)
    
68.         Next c
    
69.         tr = tr + maxtr     '下一股票填写行
    
70.     Next i
    
71.    
    
72.     [a2].Resize(tr, 34) = brr
    
73.    
    
74.     Application.DisplayAlerts = True
    
75.     Application.ScreenUpdating = True
    
76. End Sub

复制代码

grf1973

请看附件。