求助按给出表的格式汇总的代码

chxw68

这道题用字典+数组来做，代码简单，速度较快。

lzqmsy

chxw68 发表于 2014-7-17 08:54
这道题用字典+数组来做，代码简单，速度较快。

谢谢您了,正好想学学字典法,再次感谢

lzqmsy

chxw68 发表于 2014-7-17 08:54
这道题用字典+数组来做，代码简单，速度较快。

老师,您好!我学习您写的代码,把表格格式改变了一下,试着修改代码,修改成了,得到的数据都对,但是比您写的代码速度要慢很多,不知为什么?想请您看一下,给与重新修改并指点一二,谢谢了!!!附件发在下一楼

lzqmsy

求助代码2.rar (72.09 KB, 下载次数: 4)

2014-7-17 12:04 上传

点击文件名下载附件

chxw68

1. Sub 又一种格式()
   
2.   Dim d As Object
   
3.   Dim d1 As Object
   
4.   Dim r%, i%
   
5.   Dim arr, brr()
   
6.   tt = Timer
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("求助这种格式的代码")
   
10.     c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
11.     arr = .Range("a3").Resize(1, c)
    
12.   End With
    
13.   For j = 4 To UBound(arr, 2) Step 2
    
14.     d1(arr(1, j)) = j
    
15.   Next
    
16.   With Worksheets("台帐")
    
17.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     arr = .Range("a2:e" & r)
    
19.   End With
    
20.   
    
21.   For i = 1 To UBound(arr)
    
22.     If Not d.Exists(Month(arr(i, 1))) Then
    
23.       ReDim brr(1 To 13)
    
24.       brr(1) = Month(arr(i, 1))
    
25.     Else
    
26.       brr = d(Month(arr(i, 1)))
    
27.     End If
    
28.     If d1.Exists(arr(i, 2)) Then
    
29.       brr(d1(arr(i, 2))) = brr(d1(arr(i, 2))) + arr(i, 3)
    
30.       brr(d1(arr(i, 2)) + 1) = brr(d1(arr(i, 2)) + 1) + arr(i, 5)
    
31.       brr(2) = brr(2) + arr(i, 3)
    
32.       brr(3) = brr(3) + arr(i, 5)
    
33.     End If
    
34.     d(Month(arr(i, 1))) = brr
    
35.   Next
    
36.    
    
37.   With Worksheets("求助这种格式的代码")
    
38.     .UsedRange.Offset(4, 0).ClearContents
    
39.     .Range("a5").Resize(d.Count, 13) = Application.Transpose(Application.Transpose(d.Items))
    
40.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
41.     .Cells(r + 1, 1) = "合计"
    
42.     .Cells(r + 1, 2).Resize(1, 12).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
    
43.   End With
    
44.   MsgBox Timer - tt
    
45. End Sub
    

复制代码

chxw68

楼主代码运行时间是0.1秒，我修改后的代码运行时间是0.03秒。

lzqmsy

chxw68 发表于 2014-7-17 12:28
楼主代码运行时间是0.1秒，我修改后的代码运行时间是0.03秒。

看到您写的代码了,速度真快,学习了,谢谢!!!

chxw68

如果汇总表格的横竖表头固定的话，也可以使用数组的办法进行汇总。

1. Sub test4()
   
2.   Dim d As Object
   
3.   Dim d1 As Object
   
4.   Dim r%, i%
   
5.   Dim arr, brr
   
6.   tt = Timer
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   Set d2 = CreateObject("scripting.dictionary")
   
10.   With Worksheets("求助这种格式的代码")
    
11.     c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     .Range("b5").Resize(r - 4, c - 1).ClearContents
    
14.     arr = .Range("a3").Resize(r - 3, c)
    
15.   End With
    
16.   For j = 4 To UBound(arr, 2) Step 2
    
17.     d1(arr(1, j)) = j
    
18.   Next
    
19.   For i = 3 To UBound(arr)
    
20.     d2(arr(i, 1)) = i
    
21.   Next
    
22.   With Worksheets("台帐")
    
23.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.     brr = .Range("a2:e" & r)
    
25.   End With
    
26.   
    
27.   For i = 1 To UBound(brr)
    
28.     If d1.Exists(brr(i, 2)) And d2.Exists(Month(brr(i, 1))) Then
    
29.       r = d2(Month(brr(i, 1)))
    
30.       c = d1(brr(i, 2))
    
31.       arr(r, c) = arr(r, c) + brr(i, 3)
    
32.       arr(r, c + 1) = arr(r, c + 1) + brr(i, 5)
    
33.       arr(r, 2) = arr(r, 2) + brr(i, 3)
    
34.       arr(r, 3) = arr(r, 3) + brr(i, 5)
    
35.     End If
    
36.   Next
    
37.    
    
38.   With Worksheets("求助这种格式的代码")
    
39.     .UsedRange.Offset(4, 0).ClearContents
    
40.     .Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
41.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
42.     .Cells(r + 1, 1) = "合计"
    
43.     .Cells(r + 1, 2).Resize(1, 12).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
    
44.   End With
    
45.   MsgBox Timer - tt
    
46. End Sub

复制代码

chxw68

详见附件。

lzqmsy

chxw68 发表于 2014-7-17 15:34
详见附件。

试过了,这个更快,谢谢了!!!