按班求总分

哒哒哒是的撒多

按班求总分

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.1
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("a1").CurrentRegion
   
6.     ReDim brr(1 To UBound(arr), 1 To 6)
   
7.     On Error Resume Next
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 2)
   
10.         If Not d.Exists(s) Then
    
11.             m = m + 1
    
12.             d(s) = m
    
13.             brr(m, 1) = arr(i, 2)
    
14.             For j = 4 To UBound(arr, 2)
    
15.                 brr(m, j - 2) = arr(i, j)
    
16.             Next
    
17.         Else
    
18.             r = d(s)
    
19.             For x = 2 To 6
    
20.                 brr(r, x) = brr(r, x) + arr(i, x + 2)
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With Sheets("计算表")
    
25.         .UsedRange.Offset(1) = ""
    
26.         .Range("a2").Resize(m, 6) = brr
    
27.         .Range("a2").Resize(m, 6).Borders.LineStyle = 1
    
28.     End With
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    

复制代码

cnmlgb9998

.......................

LIUZHU

效果如下，结合公式

LIUZHU

JSA代码，和WPS适配

1. function 按班级计算总分(){
   
2.         let arr=Sheets.Item("信息表").Range("a1").CurrentRegion.Value2;
   
3.         let fmlr=`=SUMIF(信息表!R1C2:R${arr.length}C2,RC1,信息表!R1C[2]:R${arr.length}C[2])`;
   
4.         ["姓名","学号"].forEach(x=>arr[0].splice(arr[0].indexOf(x),1));
   
5.         let res=[...new Set(arr.slice(1).map(x=>x[1]))].reduce((res,y)=>(res.push([y,...Array(arr[0].length-1).fill(fmlr)]),res),[arr[0]]);
   
6.         Sheets.Item("计算表").Range("a1").Resize(res.length,res[0].length).FormulaR1C1=res;
   
7. }

复制代码

LIUZHU

附件在此，WPS测试

lisongmei

练习一下，python也行。

NBCBA123

1. Sub test()
   
2.     Set dic = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("信息表").Range("a1").CurrentRegion
   
4.     For a = 1 To UBound(arr)
   
5.         If Not dic.exists(arr(a, 2)) Then
   
6.             dic(arr(a, 2)) = Array(arr(a, 2), arr(a, 4), arr(a, 5), arr(a, 6), arr(a, 7), arr(a, 8))
   
7.         Else
   
8.              dic(arr(a, 2)) = Array(dic(arr(a, 2))(0), dic(arr(a, 2))(1) + arr(a, 4), _
   
9.              dic(arr(a, 2))(2) + arr(a, 5), dic(arr(a, 2))(3) + arr(a, 6), dic(arr(a, 2))(4) + arr(a, 7), dic(arr(a, 2))(5) + arr(a, 8))
   
10.         End If
    
11.     Next a
    
12.     itm = Application.Transpose(dic.items)
    
13.     Sheets("计算表").Cells.ClearContents
    
14.     Sheets("计算表").Range("a1").Resize(UBound(itm, 2), UBound(itm)) = Application.Transpose(itm)
    
15.     Set dic = Nothing
    
16. End Sub

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, dic As Object, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(1).[A1].CurrentRegion.Value
    cr = Array(2, 4, 5, 6, 7, 8)
    ReDim br(1 To UBound(ar), 1 To 6)
   
    r = r + 1
    For j = 0 To UBound(cr)
        br(r, j + 1) = ar(r, cr(j))
    Next j
   
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 2)) Then
            r = r + 1
            dic(ar(i, 2)) = r
        End If
        iPosRow = dic(ar(i, 2))
        For j = 0 To UBound(cr)
            br(iPosRow, j + 1) = br(iPosRow, j + 1) + ar(i, cr(j))
        Next j
    Next i
   
    [A1].CurrentRegion.Clear
    [A1].Resize(r, UBound(br, 2)) = br
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub