工地名称相同的进行求和，同时计算出对应的百分比

zh2783458

各们老师：通过VBA计算后，对名称相同工地的金额进行求和，同时计算出对应的百分比。 谢谢！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.29
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Range("b8:x12")
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.     For i = 1 To UBound(arr)
   
8.         s = arr(i, 1)
   
9.         If s <> Empty Then
   
10.             If Not d.Exists(s) Then
    
11.                 m = m + 1
    
12.                 d(s) = m
    
13.                 brr(m, 1) = arr(i, 1)
    
14.                 brr(m, 2) = arr(i, 2)
    
15.                 brr(m, 3) = arr(i, 3)
    
16.                 brr(m, 4) = arr(i, 4)
    
17.                 brr(m, 5) = arr(i, 5)
    
18.                 brr(m, 6) = arr(i, 6)
    
19.                 brr(m, UBound(arr, 2)) = arr(i, UBound(arr, 2))
    
20.                 For j = 7 To 22 Step 2
    
21.                     brr(m, j) = arr(i, j)
    
22.                 Next
    
23.             Else
    
24.                 r = d(s)
    
25.                 brr(r, 2) = brr(r, 2) & arr(i, 2)
    
26.                 brr(r, 4) = brr(r, 4) + arr(i, 4)
    
27.                 brr(r, 5) = brr(r, 5) + arr(i, 5)
    
28.                 brr(r, 6) = brr(r, 6) + arr(i, 6)
    
29.                 For j = 7 To 22 Step 2
    
30.                     brr(r, j) = brr(r, j) + arr(i, j)
    
31.                 Next
    
32.             End If
    
33.         End If
    
34.     Next
    
35.     Range("b16").Resize(5, 25) = ""
    
36.     Range("b16").Resize(m, UBound(arr, 2)) = brr
    
37.     For i = 16 To 16 + m - 1
    
38.         For j = 9 To 23 Step 2
    
39.             If Cells(i, j - 1) <> Empty Then
    
40.                 Cells(i, j) = Application.Round(Cells(i, j - 1) * 100 / Cells(i, 6), 2)
    
41.             End If
    
42.         Next
    
43.     Next
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    
48. 
    

复制代码

LIUZHU

参与下，刚才是看着数据有些乱

LIUZHU

JSA代码，参考下

1. function 汇总(){
   
2.         const arr=Range("b8:x"+ Range("b8").End(xlDown).Row).Value2;
   
3.         const bt=Range("b7:x7").Value2[0];
   
4.         let obj=arr.reduce((obj,x)=>{
   
5.                 let temp=obj[x[0]]=obj[x[0]] || [x[0], x[1], x[2], ...Array(bt.length-3).fill(null)];
   
6.                 for (let j=3;j<bt.length;j++){
   
7.                         if (bt[j]!=null && bt[j].includes("%")){
   
8.                                 temp[j]="=RC[-1]/RC6";
   
9.                                 continue;
   
10.                         }
    
11.                         temp[j]=x[j]==null?temp[j]:(temp[j] || 0) + x[j];
    
12.                 }
    
13.                 return obj;
    
14.         },{});
    
15.         const res=Object.values(obj);
    
16.         Range("b16").Resize(res.length,res[0].length).FormulaR1C1=res;
    
17. }

复制代码

LIUZHU

附件，请审核，WPS测试

LIUZHU

占结算%这个字段对应的记录，其实是用公式生成的。