多条件求和

chatatk

请问sheet2的效果图怎么用VBA实现

shiruiqiang

一维转二维。论坛搜索一下

wang-way

你看看我 回复的帖子  这两天才回复了一模一样的 你找找吧

wang-way

https://club.excelhome.net/forum ... amp;_dsign=76a83a04

Qs18

Sub chaxun() '多条件求和
    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
    For j = 4 To 6
        s2 = Sheet2.Cells(j, 2).Value
        For x = 3 To 33
            s3 = Sheet2.Cells(3, x).Value
            Sheet2.Cells(j, x) = IIf(dic(s2 & s3), dic(s2 & s3), 0)
            Sheet2.Cells(j, "AH").Value = Sheet2.Cells(j, "AH").Value + Sheet2.Cells(j, x).Value
        Next
    Next
    Range("C9").FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
    Range("C9").AutoFill Destination:=Range("C9:AH9"), Type:=xlFillDefault
End Sub

Qs18

试一下...........

Qs18

试一下...............

wang-way

  使用字典 定位法 比较容易实现

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.20  条件汇总
   
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(2).Find("合计").Row
    
11.         For i = 4 To r - 1
    
12.             If .Cells(i, 2) <> Empty Then
    
13.                 For j = 3 To 33
    
14.                     s = .Cells(i, 2) & "|" & .Cells(3, j)
    
15.                     If d.exists(s) Then
    
16.                         .Cells(i, j) = d(s)
    
17.                     End If
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.         For i = 4 To r - 1
    
22.             .Cells(i, 34) = Application.Sum(.Cells(i, 3).Resize(, 31))
    
23.         Next
    
24.         For j = 3 To 34
    
25.             .Cells(r, j) = Application.Sum(.Cells(4, j).Resize(r - 4))
    
26.         Next
    
27.         ActiveWindow.DisplayZeros = False
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码