多条件求和修改代码

chatatk

  如何把这个结果Sheet2.Cells(j, x) = IIf(dic(s2 & s3), dic(s2 & s3), 0)

改成数组形式

因为几个数据用这个代码没问题 但是数据一多，cells就很慢
能否改成数组提高运算效率？

wang-way

两个倒置速度变慢的操作，你这一句占两个。是频繁写入单元格，2是使用iif判断。你可以改成用数组。条件判断想办法优化一下，能否省去不要？

wang-way

你这不是前几天求助的帖子吗。

ykcbf1100

前几天应该写过一次了。这次用数组吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.27  条件汇总
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("Sheet1").UsedRange
   
5.     For i = 1 To UBound(arr)
   
6.         s = arr(i, 2) & "|" & arr(i, 4)
   
7.         d(s) = d(s) + arr(i, 3)
   
8.     Next
   
9.     With Sheets("Sheet2")
   
10.         r = .Columns(1).Find("合计").Row
    
11.         c = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r - 1, c)
    
13.         For i = 4 To r - 1
    
14.             If arr(i, 1) <> Empty Then
    
15.                 For j = 2 To UBound(arr, 2) - 1
    
16.                     s = arr(i, 1) & "|" & arr(3, j)
    
17.                     If d.exists(s) Then
    
18.                         arr(i, j) = d(s)
    
19.                     End If
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.         .[a1].Resize(r - 1, c) = arr
    
24.         For i = 4 To r - 1
    
25.             .Cells(i, c) = Application.Sum(.Cells(i, 2).Resize(, 31))
    
26.         Next
    
27.         For j = 2 To c
    
28.             .Cells(r, j) = Application.Sum(.Cells(4, j).Resize(r - 4))
    
29.         Next
    
30.         ActiveWindow.DisplayZeros = False
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

Qs18

Sub qs() '多条件求和2024/6/27
    Dim arr: arr = Sheet1.UsedRange
    Dim dic: Set dic = CreateObject("scripting.dictionary")
    Sheet2.Range("c4:ah9").Value = ""
    For i = 1 To UBound(arr)
        s = arr(i, 2) & arr(i, 4)
        If Not dic.exists(s) Then
            dic(s) = arr(i, 3)
        Else
            dic(s) = dic(s) + arr(i, 3)
        End If
    Next
    With Sheet2
    Dim brr: brr = .Range("b3:ah9")
    For j = 2 To UBound(brr) - 1
        If brr(j, 1) <> "" Then
        s2 = brr(j, 1)
            For x = 2 To UBound(brr, 2) - 1
                s3 = brr(1, x)
                brr(j, x) = IIf(dic(s2 & s3), dic(s2 & s3), 0)
                sm = sm + brr(j, x)
            Next
        End If
        brr(j, UBound(brr, 2)) = sm
        sm = 0
    Next
    .Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
    Range("C9").FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
    Range("C9").AutoFill Destination:=Range("C9:AH9"), Type:=xlFillDefault
    End With
End Sub

Qs18

试一下.......

Qs18

试一下吧......

wang-way

效果达到了吗  ？

chatatk

wang-way 发表于 2024-6-27 10:45
效果达到了吗  ？

整好了 谢谢大佬