[已解决]终于找到一个类似的，但是汇总速度太慢，请老师优化下速度。

N7120

照片：

文件：
汇总工作表.rar (91.92 KB, 下载次数: 10)

2016-1-19 20:47 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-1-20 14:47

速度秒杀SQL

1. Sub 汇总()
   
2.     Dim sht As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     rq1 = [c3]: rq2 = [e3] '起止日期
   
5.     Dim brr(1 To 10000, 1 To 5)
   
6.     For Each sht In Worksheets
   
7.         If sht.Name Like "数据*" Then
   
8.             arr = sht.Range("a1:k" & sht.[d65536].End(3).Row)
   
9.             For i = 10 To UBound(arr)
   
10.                 If Len(arr(i, 4)) > 0 Then
    
11.                     rq = arr(i, 4)
    
12.                     x = arr(i, 6)
    
13.                     If Not d.Exists(x) Then
    
14.                         n = n + 1: d(x) = n
    
15.                         brr(n, 1) = x
    
16.                     End If
    
17.                     p = d(x)
    
18.                     If rq < rq1 Then          '日期在指定日期之前，期初值
    
19.                         brr(p, 2) = brr(p, 2) + arr(i, 10)
    
20.                         brr(p, 3) = brr(p, 3) + arr(i, 11)
    
21.                     ElseIf rq <= rq2 Then          '日期在指定日期之间，本期值
    
22.                         brr(p, 4) = brr(p, 4) + arr(i, 10)
    
23.                         brr(p, 5) = brr(p, 5) + arr(i, 11)
    
24.                     End If
    
25.                 End If
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     [b6:f10000].ClearContents
    
30.     If n > 0 Then [b6].Resize(n, 5) = brr
    
31. End Sub

复制代码

跳转到最佳答案楼层

N7120

{:1112:}{:1112:}{:1112:}{:1112:}{:1112:}{:1112:}{:1112:}{:1112:}

xm2012

不懂，支持下！

grf1973

速度秒杀SQL

1. Sub 汇总()
   
2.     Dim sht As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     rq1 = [c3]: rq2 = [e3] '起止日期
   
5.     Dim brr(1 To 10000, 1 To 5)
   
6.     For Each sht In Worksheets
   
7.         If sht.Name Like "数据*" Then
   
8.             arr = sht.Range("a1:k" & sht.[d65536].End(3).Row)
   
9.             For i = 10 To UBound(arr)
   
10.                 If Len(arr(i, 4)) > 0 Then
    
11.                     rq = arr(i, 4)
    
12.                     x = arr(i, 6)
    
13.                     If Not d.Exists(x) Then
    
14.                         n = n + 1: d(x) = n
    
15.                         brr(n, 1) = x
    
16.                     End If
    
17.                     p = d(x)
    
18.                     If rq < rq1 Then          '日期在指定日期之前，期初值
    
19.                         brr(p, 2) = brr(p, 2) + arr(i, 10)
    
20.                         brr(p, 3) = brr(p, 3) + arr(i, 11)
    
21.                     ElseIf rq <= rq2 Then          '日期在指定日期之间，本期值
    
22.                         brr(p, 4) = brr(p, 4) + arr(i, 10)
    
23.                         brr(p, 5) = brr(p, 5) + arr(i, 11)
    
24.                     End If
    
25.                 End If
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     [b6:f10000].ClearContents
    
30.     If n > 0 Then [b6].Resize(n, 5) = brr
    
31. End Sub

复制代码