用VBA代码代替SUMIFS

stsniper

    各位大神求解脱啊 ！公司要一个表格，之前用函数，由于数据不断增加就不是很好用了，自己在网上找了点资料照着写了些代码，由于学艺不精出来的程序不能达到效果，望各位大神给指正一下。详情见附件！谢谢！

lsc900707

用字典代替公式好了。

stsniper

就是用了，但是没有成功呀，大神给瞧瞧！

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheet13.[a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         s = arr(i, 1) & arr(i, 4) & arr(i, 5)
   
6.         If Not d.exists(s) Then
   
7.             d(s) = arr(i, 3)
   
8.         Else
   
9.             d(s) = d(s) + arr(i, 3)
   
10.         End If
    
11.     Next
    
12.     brr = [a1].CurrentRegion
    
13.     For i = 4 To UBound(brr)
    
14.         For j = 8 To 42
    
15.             s = brr(i, 1) & brr(2, j) & brr(3, j)
    
16.             If d.exists(s) Then brr(i, j) = d(s)
    
17.         Next
    
18.     Next
    
19.     [a1].CurrentRegion = brr
    
20. End Sub

复制代码

stsniper

lsc900707 发表于 2018-6-14 21:11

大神，测试了一下，求出的统计数有点不对。

lsc900707

stsniper 发表于 2018-6-14 21:59
大神，测试了一下，求出的统计数有点不对。

有合并单元格，修改代码如下：

1. Sub gj23w98()
   
2.     tms = Timer
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet13.[a1].CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         s = arr(i, 1) & arr(i, 4) & arr(i, 5)
   
7.         If Not d.exists(s) Then
   
8.             d(s) = arr(i, 3)
   
9.         Else
   
10.             d(s) = d(s) + arr(i, 3)
    
11.         End If
    
12.     Next
    
13.     brr = [a1].CurrentRegion
    
14.     For i = 4 To UBound(brr)
    
15.         For j = 8 To 42
    
16.             If Cells(2, j).MergeCells Then brr(2, j) = Cells(2, j).MergeArea.Cells(1, 1)
    
17.             s = brr(i, 1) & brr(2, j) & brr(3, j)
    
18.             If d.exists(s) Then brr(i, j) = d(s)
    
19.         Next
    
20.     Next
    
21.     [a1].CurrentRegion = brr
    
22.     MsgBox Format(Timer - tms, "0.0000s")
    
23. End Sub

复制代码

lsc900707

stsniper 发表于 2018-6-14 21:59
大神，测试了一下，求出的统计数有点不对。

修改的代码需要审核，先回传附件以供测试：

stsniper

lsc900707 发表于 2018-6-16 15:17
修改的代码需要审核，先回传附件以供测试：

感谢大神，问题解决了 ！谢谢！

lsc900707

stsniper 发表于 2018-6-19 10:59
感谢大神，问题解决了 ！谢谢！

不客气。解决了问题最重要。

stsniper

lsc900707 发表于 2018-6-19 11:22
不客气。解决了问题最重要。

大神，还有一个小问题 ，为了满足我整个表的使用，我对代买做了小范围的改动，运行时表格就无响应了。
代买入小
Sub summation1()
    Application.EnableEvents = False
    Dim d As Object, i, j, s, arr, brr, tms
    tms = Timer
    Set d = CreateObject("Scripting.Dictionary")

        arr = Sheet13.[a1].CurrentRegion

        For i = 2 To UBound(arr)

       s = arr(i, 1) & arr(i, 4) & arr(i, 5) & arr(i, 7)

       If Not d.exists(s) Then

           d(s) = arr(i, 3)

       Else

          d(s) = d(s) + arr(i, 3)

       End If

    Next

   brr = Sheet12.[a1].CurrentRegion

   For i = 4 To UBound(brr)

       For j = 8 To 611

           If Cells(2, j).MergeCells Then brr(2, j) = Cells(2, j).MergeArea.Cells(1, 1)
           If Cells(1, j).MergeCells Then brr(1, j) = Cells(1, j).MergeArea.Cells(1, 1)

           s = brr(i, 1) & brr(2, j) & brr(3, j) & brr(1, j)

         If d.exists(s) Then brr(i, j) = d(s)

      Next

   Next

   [a1].CurrentRegion = brr

   MsgBox Format(Timer - tms, "0.0000s")
Application.EnableEvents = True

End Sub