如何通过VBA汇总EXCEL工作表中的数据

zhang2018

财务工作经常需要统计各类各部门的费用情况，由于数据太多，通过数组汇总太慢，数据透视又无法满足要求（因为要求统计的结果格式是固定等原因），因此请求各位高手如何通过VBA汇总统计数据，我只了解一点点VBA，请高手不厌其烦详细地设计好后上传，感谢。
要求：根据“Sheet1”工作表所提供的格式（不允许改变格式），把“Sheet2”工作表中的数据统计到“Sheet1”中。详情见附件。

[ 本帖最后由 zhang2018 于 2011-5-22 17:29 编辑 ]

flyanfl

楼主能具体说说为什么数据透视表不行吗？

zhang2018

报给领导的报表格式是固定的，每个部门每个月并不一定都有数据发生，因此数据透视表的结果格式一定会变化。而且，上传的数据进行了简化，实际的数据远远比这复杂，数据也很庞大，数据透视的弱点是占用磁盘太多，保存后再次打开太慢啦。

xmyjk

用SQL作的，你看看大数据量如何，估计还是比较一般，要快还是要字典和数组，有空再写。excel稍后

1. Sub total()
   
2. Dim mxsm As String, bmsm As String, t As Single
   
3. 
   
4. t = Timer
   
5. With Sheet1
   
6. Application.ScreenUpdating = False
   
7. .[c3:h12].ClearContents
   
8.    
   
9. Set cnn = CreateObject("adodb.connection")
   
10. cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ActiveWorkbook.FullName
    
11. 
    
12. For i = 1 To .[b65536].End(3).Row - 2
    
13.    For j = 1 To .[iv2].End(xlToLeft).Column - 2
    
14.        mxsm = .Cells(i + 2, 2)
    
15.        bmsm = .Cells(2, j + 2)
    
16.        Sql = "select sum(金额) from [Sheet2$] WHERE 明细说明 = '" & mxsm & "' AND 部门说明= '" & bmsm & "' GROUP BY 明细说明, 部门说明"
    
17.        .Cells(i + 2, j + 2).CopyFromRecordset cnn.Execute(Sql)
    
18.    Next
    
19. Next
    
20. 
    
21. cnn.Close
    
22. Set cnn = Nothing
    
23. Application.ScreenUpdating = True
    
24. End With
    
25. 
    
26. MsgBox Timer - t & "秒"
    
27. End Sub

复制代码

xmyjk

附件如下，试看看吧。

陈国华

5楼够专业，顶!  学习中。。。

xmyjk

1. Option Explicit
   
2. Sub samesum()
   
3. Dim i As Long, n As Long, arr(), j As Long
   
4. Dim d, t As Single
   
5. 
   
6. t = Timer
   
7. Set d = CreateObject("Scripting.Dictionary")
   
8. n = Sheet2.[a65536].End(xlUp).Row
   
9. arr = Sheet2.Range("a2:c" & n)
   
10. For i = 1 To UBound(arr)
    
11.     d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
    
12. Next
    
13. 
    
14. Sheet1.[c3:h12].ClearContents
    
15. Erase arr
    
16. arr = Sheet1.Range(Sheet1.Cells(2, 2), Sheet1.Cells(Sheet1.[B65536].End(3).Row, Sheet1.[IV2].End(xlToLeft).Column))
    
17. For i = 1 To UBound(arr, 1) - 1
    
18.     For j = 1 To UBound(arr, 2) - 1
    
19.        arr(i + 1, j + 1) = d(arr(i + 1, 1) & arr(1, j + 1))
    
20.     Next
    
21. Next
    
22. 
    
23. Sheet1.[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
24. Erase arr
    
25. Set d = Nothing
    
26. 
    
27. MsgBox Timer - t & "秒"
    
28. End Sub

复制代码

xmyjk

自己试看看附件吧，把字典和SQL两种方法都做进去了，明显字典快非常多。两种方法正好相互验证准确性。

zhang2018

太牛了，长见识，非常感谢，我慢慢研究进行改造，遇到不懂的望不吝赐教，好激动啊！

xmyjk

原帖由 zhang2018 于 2011-5-22 20:51 发表
太牛了，长见识，非常感谢，我慢慢研究进行改造，遇到不懂的望不吝赐教，好激动啊！

呃，不客气，不用激动，好好学习天天向上即可，很快你也会都懂的，都不是些很难的东西。
也欢迎新人啦，有空多来论坛逛逛。有很多好东西滴。