[已解决]求一个汇总求和模块

icenotcool

各位老师，我想求取一个汇总提取并求和的模块，详情请见附件 求和实例.rar (811.02 KB, 下载次数: 15)

2016-2-25 20:38 上传

点击文件名下载附件 ，谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2016-2-26 11:15

右边的数据是原公式结果，供比较。

1. Sub 求和()
   
2.     Dim sh As Worksheet
   
3.     arr = Range("d3:d" & [d65536].End(3).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 3)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 1 To UBound(arr)
   
7.         d(arr(i, 1)) = i
   
8.     Next
   
9.     For Each sh In Worksheets
   
10.         If sh.Name Like "*年*月" Then
    
11.             crr = sh.Range("a10:ag" & sh.[e65536].End(3).Row)
    
12.             For k = 1 To UBound(crr)
    
13.                 i = d(crr(k, 5))
    
14.                 If i > 0 Then
    
15.                     brr(i, 1) = brr(i, 1) + crr(k, 12)
    
16.                     brr(i, 2) = brr(i, 2) + crr(k, 28)
    
17.                     brr(i, 3) = brr(i, 3) + crr(k, 33)
    
18.                 End If
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     Range("L3").Resize(UBound(brr), 3) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

金樽空对月

见附件，试试看。

icenotcool

金樽空对月 发表于 2016-2-25 23:45
见附件，试试看。

老师，老师我把你的模块放进我的电脑，数据不对，这个是我实际附件 实例.rar (836.61 KB, 下载次数: 5)

2016-2-26 09:22 上传

点击文件名下载附件 ，那个登录用户随便哪个都可以，密码为空，麻烦你看看，然后可以请你解释一下你是怎么定义取数源表的呢，而不会取错工作表的的呢？

金樽空对月

icenotcool 发表于 2016-2-26 09:23
老师，老师我把你的模块放进我的电脑，数据不对，这个是我实际附件，那个登录用户随便哪个都可以，密码为 ...

你给的对比正确数据貌似也有些不对呀，能不能说一下你是怎么算的。

grf1973

右边的数据是原公式结果，供比较。

1. Sub 求和()
   
2.     Dim sh As Worksheet
   
3.     arr = Range("d3:d" & [d65536].End(3).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 3)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 1 To UBound(arr)
   
7.         d(arr(i, 1)) = i
   
8.     Next
   
9.     For Each sh In Worksheets
   
10.         If sh.Name Like "*年*月" Then
    
11.             crr = sh.Range("a10:ag" & sh.[e65536].End(3).Row)
    
12.             For k = 1 To UBound(crr)
    
13.                 i = d(crr(k, 5))
    
14.                 If i > 0 Then
    
15.                     brr(i, 1) = brr(i, 1) + crr(k, 12)
    
16.                     brr(i, 2) = brr(i, 2) + crr(k, 28)
    
17.                     brr(i, 3) = brr(i, 3) + crr(k, 33)
    
18.                 End If
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     Range("L3").Resize(UBound(brr), 3) = brr
    
23. End Sub

复制代码

icenotcool

grf1973 发表于 2016-2-26 11:15
右边的数据是原公式结果，供比较。

谢谢金樽空对月老师和5楼GRF1973老师耐心的解答，问题解决了，金樽空对月老师你的模块应该是取表的时候出了问题，应该是按GRF1973老师的 If sh.Name Like "*年*月" Then这样就行了，非常感谢两位老师[em20]

icenotcool

grf1973 发表于 2016-2-26 11:15
右边的数据是原公式结果，供比较。

谢谢金樽空对月老师和5楼GRF1973老师耐心的解答，问题解决了，金樽空对月老师你的模块应该是取表的时候出了问题，应该是按GRF1973老师的 If sh.Name Like "*年*月" Then这样就行了，非常感谢两位老师

icenotcool

grf1973 发表于 2016-2-26 11:15
右边的数据是原公式结果，供比较。

老师可以看看我的这个语句出问题在哪儿吗？问题已经解决
Sub 求和()
    Dim sh As Worksheet
    arr = Range("b2:b" & [b65536].End(2).Row)
    ReDim brr(1 To UBound(arr), 1 To 4)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    For Each sh In Worksheets
        If sh.Name Like "*5年*月" Then
            crr = sh.Range("a3:ac" & sh.[a65536].End(3).Row)
            For k = 1 To UBound(crr)
                i = d(crr(k, 1))
                If i > 0 Then
                    brr(i, 1) = brr(i, 1) + crr(k, 7)
                    brr(i, 2) = brr(i, 2) + crr(k, 8)
                    brr(i, 3) = brr(i, 3) + crr(k, 9)
                    brr(i, 4) = brr(i, 4) + crr(k, 10)
                End If
            Next
        End If
    Next
    Range("E2").Resize(UBound(brr), 4) = brr
End Sub