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

zax010

lzqmsy 发表于 2014-7-16 16:34
老师你好,你写的代码我今天学习很长时间,颇有收获,谢谢您,还要请教一下,用sql能否实现,等待您的回复

抱歉，sql 我也正在学，还没学会不敢出手，请用9楼chxw68大师的代码。

lzqmsy

chxw68 发表于 2014-7-16 17:09
参见附件。

老师,您好!谢谢您的回复,看过了,好像合计数据不对,是不是代码哪里需要修改一下,等待您的回复,再次谢谢了!!!

lzqmsy

zax010 发表于 2014-7-16 18:53
抱歉，sql 我也正在学，还没学会不敢出手，请用9楼chxw68大师的代码。

您好,谢谢您的再次回复,9楼的代码有点小问题,合计数据不对,小于正确的合计数

chxw68

lzqmsy 发表于 2014-7-16 20:09
老师,您好!谢谢您的回复,看过了,好像合计数据不对,是不是代码哪里需要修改一下,等待您的回复,再次谢谢了! ...

哪个合计不对？

lzqmsy

chxw68 发表于 2014-7-16 20:32
哪个合计不对？

数量合计和销售金额合计都不对,就是第2列和第3列,再次谢谢!!!

lzqmsy

哦,我发现了,个别省份没有合计数,所以总合计数不对

chxw68

详见附件。

lzqmsy

chxw68 发表于 2014-7-16 20:32
哪个合计不对？

好了,问题解决了,将crr(j + 1, 2) = crr(j + 1, 2)+arr(i, j)改成crr(j + 1, 2) = IIf(IsNull(crr(j + 1, 2)), 0, crr(j + 1, 2)) + IIf(IsNull(arr(i, j)), 0, arr(i, j))
将crr(j + 1, 3) = crr(j + 1, 3) +brr(i, j)改成crr(j + 1, 3) = IIf(IsNull(crr(j + 1, 3)), 0, crr(j + 1, 3)) + IIf(IsNull(brr(i, j)), 0, brr(i, j))

lzqmsy

chxw68 发表于 2014-7-16 21:28
详见附件。

谢谢您的再次回复,向您学习

chxw68

这个问题适合用字典解决，用时0.06秒，而用ADO+SQL用时0.12秒，时间节省了一半。

1. Sub test2()
   
2.   Dim d As Object
   
3.   Dim r%, i%
   
4.   Dim arr, brr()
   
5.   tt = Timer
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("台帐")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:e" & r)
   
10.   End With
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d.Exists(arr(i, 2)) Then
    
13.       ReDim brr(1 To 27)
    
14.       brr(1) = arr(i, 2)
    
15.     Else
    
16.       brr = d(arr(i, 2))
    
17.     End If
    
18.     n = Month(arr(i, 1))
    
19.     brr(n * 2 + 2) = brr(n * 2 + 2) + arr(i, 3)
    
20.     brr(n * 2 + 3) = brr(n * 2 + 3) + arr(i, 5)
    
21.     brr(2) = brr(2) + arr(i, 3)
    
22.     brr(3) = brr(3) + arr(i, 5)
    
23.     d(arr(i, 2)) = brr
    
24.   Next
    
25.    
    
26.   With Worksheets("我要的效果")
    
27.     .UsedRange.Offset(4, 0).ClearContents
    
28.     .Range("a5").Resize(d.Count, 27) = Application.Transpose(Application.Transpose(d.Items))
    
29.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
30.     .Cells(r + 1, 1) = "合计"
    
31.     .Cells(r + 1, 2).Resize(1, 26).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
    
32.   End With
    
33.   MsgBox Timer - tt
    
34. End Sub
    

复制代码