求一段多条件求和汇总代码,数据量大不想用公式公式解决

Yedajun

lizhipei78 发表于 2024-5-7 22:21
经典一维转二维，用三个字典最简单最好理解

问一下UBound ( Arr ,2)这句是不是多了一个“2”

全党

1. Sub tongji()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. 
   
6. arr = Range("a2").CurrentRegion
   
7. brr = Range("g1").CurrentRegion
   
8. For i = 2 To UBound(arr)
   
9. Key = arr(i, 1) & arr(i, 2)
   
10.     If Not d.exists(Key) Then
    
11.      d(Key) = arr(i, 3)
    
12.     Else
    
13.      d(Key) = d(Key) + arr(i, 3)
    
14.     End If
    
15. Next
    
16. 
    
17. For j = 3 To UBound(brr)
    
18.    For k = 2 To UBound(brr, 2)
    
19.    brr(j, k) = d(brr(j, 1) & brr(2, k))
    
20.    Next
    
21. Next
    
22. Range("g1").CurrentRegion = brr
    
23. Application.ScreenUpdating = True
    
24. Application.DisplayAlerts = True
    
25. End Sub

复制代码

全党

1. Sub tongji()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. 
   
6. arr = Range("a2").CurrentRegion
   
7. brr = Range("g1").CurrentRegion
   
8. For i = 2 To UBound(arr)
   
9. Key = arr(i, 1) & arr(i, 2)
   
10.     If Not d.exists(Key) Then
    
11.      d(Key) = arr(i, 3)
    
12.     Else
    
13.      d(Key) = d(Key) + arr(i, 3)
    
14.     End If
    
15. Next
    
16. 
    
17. For j = 3 To UBound(brr)
    
18.    For k = 2 To UBound(brr, 2)
    
19.    brr(j, k) = d(brr(j, 1) & brr(2, k))
    
20.    Next
    
21. Next
    
22. Range("g1").CurrentRegion = brr
    
23. Application.ScreenUpdating = True
    
24. Application.DisplayAlerts = True
    
25. End Sub

复制代码

blackttea1

感兴趣，谢谢

leeson7502

参与一下，数据区域Change，汇总区域自动更新。

cyq4896

Sub test()
    Set dic = CreateObject("scripting.dictionary")
    arr = [a2].CurrentRegion
    For i = 2 To UBound(arr)
        xm = arr(i, 1) & arr(i, 2)
        If Not dic.exists(xm) Then
            dic(xm) = arr(i, 3)
        Else
            dic(xm) = dic(xm) + arr(i, 3)
        End If
    Next
    Range("h3:j" & Rows.Count) = ""
    brr = [g1].CurrentRegion
    For i = 3 To UBound(brr)
        For j = 2 To UBound(brr, 2)
            xm = brr(i, 1) & brr(2, j)
            If dic.exists(xm) Then
                brr(i, j) = dic(xm)
            End If
        Next
    Next
    [g1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

cyq4896

参与 一下...

zhangcheng6688

ykcbf1100 发表于 2024-5-7 18:58
参与一下。。。

向老师学习

lisga1103

PQ一步直接生成结果，还可以随源数据变化而更新，比VBA简单很多

wang-way

JSA 练手

1. function transform(){
   
2.                 let sht=ThisWorkbook.Worksheets.Item(1);
   
3.                 let ar=sht.Range('a2').CurrentRegion.Value2;
   
4.                 let dr=new Set(ar.map(x=>x[0]));
   
5.                 let dc=new Set(ar.slice(1).map(x=>x[1]));
   
6.                 let br=[]
   
7.                 br.push([Array.from(dr)[0],...dc.keys()]);
   
8.                 Array.from(dr).slice(1).forEach(x=>{
   
9.                         let r=[];
   
10.                         dc.forEach(y=>{
    
11.                                 let        tmp=ar.filter(a=>a[0]==x && a[1]==y).map(x=>x[2]);
    
12.                                 if(tmp.length==0){
    
13.                                         r.push('');
    
14.                                 }else{
    
15.                                         r.push(tmp.reduce((a,c)=>a+c));
    
16.                                 }
    
17.                         })
    
18.                         r.unshift(x);
    
19.                         br.push(r);
    
20.                 })
    
21.                 sht.Range('g2').Resize(br.length,br[0].length).Value2=br;
    
22. }

复制代码