|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 计算()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
r = .Cells(Rows.Count, 5).End(xlUp).Row
If r < 3 Then MsgBox "成绩表为空！": End
.Range("l3:t" & r) = Empty
ar = .Range("a2:t" & r)
For i = 2 To UBound(ar)
If Trim(ar(i, 4)) <> "" Then d(Trim(ar(i, 4))) = ""
zf = 0
For j = 7 To 11
If Trim(ar(i, j)) <> "" Then
If IsNumeric(ar(i, j)) Then
If ar(i, j) >= 85 Then
ar(i, j + 5) = "A"
ElseIf ar(i, j) >= 70 And ar(i, j) < 85 Then
ar(i, j + 5) = "B"
ElseIf ar(i, j) >= 60 And ar(i, j) < 70 Then
ar(i, j + 5) = "C"
ElseIf ar(i, j) < 60 Then
ar(i, j + 5) = "D"
End If
End If
zf = zf + ar(i, j)
End If
Next j
ar(i, 17) = zf
Next i
.Range("a3:t" & r) = Empty
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 4)) = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
For i = 1 To n
For s = i + 1 To n
If br(i, 17) < br(s, 17) Then
For j = 1 To UBound(br, 2)
kk = br(i, j)
br(i, j) = br(s, j)
br(s, j) = kk
Next j
End If
Next s
br(i, 18) = i
Next i
rs = .Cells(Rows.Count, 5).End(xlUp).Row + 1
.Cells(rs, 1).Resize(n, UBound(br, 2)) = br
For i = rs To rs + n - 1
.Cells(i, 18) = Application.Rank(.Cells(i, 17), .Range("q3:q" & UBound(ar) + 1))
Next i
Next k
For i = 3 To UBound(ar) + 1
.Cells(i, 19) = Application.Rank(.Cells(i, 17), .Range("q3:q" & UBound(ar) + 1))
Next
End With
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-4-26 23:35
发表于 2023-4-27 07:06
楼主
