[已解决]求公式计算部份（SUMIF部份）用VBA代码实现?

pangwen_822

     求把表中公式计算部份（SUMIF部份）用VBA代码实现，不要说用公式更快，就是因为销售明细数量太多，这只是我抽取的一部份，用公式导致运算得很慢，想改回VBA代码！谢谢了，各位老师帮下忙、、、注意啊！因为此表要整批数据复到其他表应用，所以客户排列最好一经按某次排例就不要随意变化！
附件： 公式变代码.rar (10.42 KB, 下载次数: 46)

2012-9-6 15:11 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

suye1010

2012-9-8 20:37

1. Sub SalesSum()
   
2. Dim dSales, dIncome1, dIncome2, i As Integer, j As Integer, k, arr, m As Integer, Temp
   
3. Set dSales = CreateObject("Scripting.Dictionary")
   
4. Set dIncome1 = CreateObject("Scripting.Dictionary")
   
5. Set dIncome2 = CreateObject("Scripting.Dictionary")
   
6. arr = Sheets("销售明细").Range("A3:K" & Sheets("销售明细").Cells(65536, 1).End(xlUp).Row)
   
7. For m = 1 To UBound(arr, 1)
   
8.     Temp = dSales(arr(m, 2))
   
9.     Temp = dIncome1(arr(m, 2))
   
10.     Temp = dIncome2(arr(m, 2))
    
11. Next m
    
12. For j = 1 To 7
    
13.     For i = 1 To UBound(arr, 1)
    
14.         If CStr(arr(i, 1)) = CStr(2012 & Cells(2, j * 3 - 1)) Then
    
15.                 dSales(arr(i, 2)) = dSales(arr(i, 2)) + arr(i, 4)
    
16.                 dIncome1(arr(i, 2)) = dIncome1(arr(i, 2)) + arr(i, 7) + arr(i, 8)
    
17.                 dIncome2(arr(i, 2)) = dIncome2(arr(i, 2)) + arr(i, 10) + arr(i, 11)
    
18.         End If
    
19.     Next i
    
20.     Cells(4, j * 3 - 1).Resize(dSales.Count, 1) = Application.Transpose(dSales.Items)
    
21.     Cells(4, j * 3).Resize(dSales.Count, 1) = Application.Transpose(dIncome1.Items)
    
22.     Cells(4, j * 3 + 1).Resize(dSales.Count, 1) = Application.Transpose(dIncome2.Items)
    
23.     For Each k In dSales.keys
    
24.         dSales(k) = 0
    
25.         dIncome1(k) = 0
    
26.         dIncome2(k) = 0
    
27.     Next
    
28. Next j
    
29. Cells(4, 1).Resize(dSales.Count, 1) = Application.Transpose(dSales.keys)
    
30. Set dSales = Nothing
    
31. Set dIncome1 = Nothing
    
32. Set dIncome2 = Nothing
    
33. End Sub

复制代码

公式变代码.rar (16.06 KB, 下载次数: 84)

2012-9-8 20:37 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Sub SalesSum()
   
2. Dim dSales, dIncome1, dIncome2, i As Integer, j As Integer, k, arr, m As Integer, Temp
   
3. Set dSales = CreateObject("Scripting.Dictionary")
   
4. Set dIncome1 = CreateObject("Scripting.Dictionary")
   
5. Set dIncome2 = CreateObject("Scripting.Dictionary")
   
6. arr = Sheets("销售明细").Range("A3:K" & Sheets("销售明细").Cells(65536, 1).End(xlUp).Row)
   
7. For m = 1 To UBound(arr, 1)
   
8.     Temp = dSales(arr(m, 2))
   
9.     Temp = dIncome1(arr(m, 2))
   
10.     Temp = dIncome2(arr(m, 2))
    
11. Next m
    
12. For j = 1 To 7
    
13.     For i = 1 To UBound(arr, 1)
    
14.         If CStr(arr(i, 1)) = CStr(2012 & Cells(2, j * 3 - 1)) Then
    
15.                 dSales(arr(i, 2)) = dSales(arr(i, 2)) + arr(i, 4)
    
16.                 dIncome1(arr(i, 2)) = dIncome1(arr(i, 2)) + arr(i, 7) + arr(i, 8)
    
17.                 dIncome2(arr(i, 2)) = dIncome2(arr(i, 2)) + arr(i, 10) + arr(i, 11)
    
18.         End If
    
19.     Next i
    
20.     Cells(4, j * 3 - 1).Resize(dSales.Count, 1) = Application.Transpose(dSales.Items)
    
21.     Cells(4, j * 3).Resize(dSales.Count, 1) = Application.Transpose(dIncome1.Items)
    
22.     Cells(4, j * 3 + 1).Resize(dSales.Count, 1) = Application.Transpose(dIncome2.Items)
    
23.     For Each k In dSales.keys
    
24.         dSales(k) = 0
    
25.         dIncome1(k) = 0
    
26.         dIncome2(k) = 0
    
27.     Next
    
28. Next j
    
29. Cells(4, 1).Resize(dSales.Count, 1) = Application.Transpose(dSales.keys)
    
30. Set dSales = Nothing
    
31. Set dIncome1 = Nothing
    
32. Set dIncome2 = Nothing
    
33. End Sub

复制代码

公式变代码.rar (16.06 KB, 下载次数: 84)

2012-9-8 20:37 上传

点击文件名下载附件

pangwen_822

suye1010 发表于 2012-9-8 20:37

谢谢！谢班主日理万机中抽时间为我们排忧解难！