[已解决]不用字典能否统计数组中每个值种类各有多少行

lku898786

我从数据库里提取了一个200多万行、10列的二维数组，我的思路是先求出每行有几种不同值，由于10列是固定的，那么每行最低有一种，最高有10种，下面是我写的代码（提取数组的代码省略了，下面的代码是假设数组arr已经提取到了）：

1. sub NumberStatistics()
   
2. dim i&,j&
   
3. dim arr,t,d
   
4. Application.ScreenUpdating=False
   
5. Redim t(1 to 10,1 to 2)                         '数组t用来存储每类各有多少行
   
6. for i=Lbound(t) to Ubound(t)
   
7.     t(i,1)=i
   
8. next
   
9. set d=CreateObject("Scripting.Dictionary")
   
10. for i=Lbound(arr) to Ubound(arr)
    
11.     for j=Lbound(arr,2) to Ubound(arr,2)
    
12.         d(arr(i,j))=""
    
13.     next
    
14.     t(d.count,2)=t(d.count,2)+1
    
15.     d.Removeall
    
16. next
    
17. [a1].Resize(Ubound(t),Ubound(t,2))=t
    
18. Set d=Nothing
    
19. Application.ScreenUpdating=True
    
20. End Sub

复制代码

请教各路大神，这段代码能否优化，能否不使用字典达到效果，200多万行数据用字典运行速度比较令人难以忍受，因为我整个数据处理还有其他很多工作要做。拜求各位支招，多谢多谢！

最佳答案

月排行榜 / 总排行榜

上清宫主

2015-8-30 08:05

不用字典时我喜欢这样写：
stmp$="|"
scount%=0
for j=Lbound(arr,2) to Ubound(arr,2)
    if instr(stmp,"|"  ＆ arr(i,j) ＆ "|")<1 then stmp=stmp  ＆ arr(i,j) ＆ "|":scount=scount+1
next
这样，scount就是你的d.count

这样十来个值我也不喜欢用字典，不过没比较过哪个快。正好你可以测试一下。

你原代码不用removeall，而是把key改造一下，再测试一下哪个快呢

跳转到最佳答案楼层

上清宫主

不用字典时我喜欢这样写：
stmp$="|"
scount%=0
for j=Lbound(arr,2) to Ubound(arr,2)
    if instr(stmp,"|"  ＆ arr(i,j) ＆ "|")<1 then stmp=stmp  ＆ arr(i,j) ＆ "|":scount=scount+1
next
这样，scount就是你的d.count

这样十来个值我也不喜欢用字典，不过没比较过哪个快。正好你可以测试一下。

你原代码不用removeall，而是把key改造一下，再测试一下哪个快呢

lku898786

上清宫主 发表于 2015-8-30 08:05
不用字典时我喜欢这样写：
stmp$="|"
scount%=0

很巧妙的思路啊，不错不错！速度待测试后再告诉你！
兄弟，如果有机会见面的话，一定要请你吃饭。

lku898786

上清宫主 发表于 2015-8-30 08:05
不用字典时我喜欢这样写：
stmp$="|"
scount%=0

经过测试110万行6列的数组，循环部分的语句运行时间：
1、用字典、动态数组大约为21秒多
2、用你的方法、动态数组大约为19秒多，效果并不明显
3、用你的方法、数组在声明时指明数据类型（&或%），差别就明显了，大约只要13秒

非常感谢你提供的思路，再次感谢！

希望其他能人高手如果还有什么更好的方法，请不吝赐教啊！！！

grf1973

试试这个。前提是要已知数组arr的最大最小值（当然可以用估算的）。这个思路和上清的基本相同，只不过把字符串改成了数组。

1. Sub NumberStatistics()
   
2.     t1 = Timer
   
3.     Dim i&, j&
   
4.     arr = [a1].CurrentRegion
   
5.     xmin = 1      'Application.Min(arr)
   
6.     xmax = 10          'Application.Max(arr)
   
7.     Application.ScreenUpdating = False
   
8.     ReDim t(1 To 10, 1 To 2)                        '数组t用来存储每类各有多少行
   
9.     ReDim crr(1 To UBound(arr), xmin To xmax)
   
10.     For i = LBound(t) To UBound(t)
    
11.         t(i, 1) = i
    
12.     Next
    
13.    
    
14.     For i = LBound(arr) To UBound(arr)
    
15.         s = 0
    
16.         For j = LBound(arr, 2) To UBound(arr, 2)
    
17.             If crr(i, arr(i, j)) = "" Then crr(i, arr(i, j)) = 1: s = s + 1
    
18.         Next
    
19.         t(s, 2) = t(s, 2) + 1
    
20.     Next
    
21.     [m1].Resize(UBound(t), UBound(t, 2)) = t
    
22.     Set d = Nothing
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox Timer - t1
    
25. End Sub
    

复制代码

grf1973

测试了一下6万*10的数组，循环开始到结束用时0.14秒

grf1973

1. crr定义类型后速度更快，60000*10，0.09秒。
   
2. Sub NumberStatistics()
   
3.     Dim i&, j&, s%
   
4.     arr = [a1].CurrentRegion
   
5.     xmin = 1      'Application.Min(arr)
   
6.     xmax = 10          'Application.Max(arr)
   
7.     Application.ScreenUpdating = False
   
8.     t1 = Timer
   
9.     ReDim t(1 To 10, 1 To 2)                        '数组t用来存储每类各有多少行
   
10.     ReDim crr%(1 To UBound(arr), xmin To xmax)
    
11.     For i = LBound(t) To UBound(t)
    
12.         t(i, 1) = i
    
13.     Next
    
14.    
    
15.     For i = LBound(arr) To UBound(arr)
    
16.         s = 0
    
17.         For j = LBound(arr, 2) To UBound(arr, 2)
    
18.             If crr(i, arr(i, j)) = 0 Then crr(i, arr(i, j)) = 1: s = s + 1
    
19.         Next
    
20.         t(s, 2) = t(s, 2) + 1
    
21.     Next
    
22.     [m1].Resize(UBound(t), UBound(t, 2)) = t
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox Timer - t1
    
25. End Sub

复制代码

lku898786

grf1973 发表于 2015-8-31 17:01

妙载！妙载！
借用星爷的一句话：真是高高手！
希望以后能与你们多交流！

上清宫主

你的数据全是数字没文本？
时空肯定也不对
哈哈哈……

高山之岫

已阅