谢谢楼主分享作者: hnhjly 时间: 2019-5-24 17:38
谢谢楼主分享作者: hnhjly 时间: 2019-5-24 17:43
Sub test2()
Dim r%, i%
Dim arr, brr
Dim ws As Worksheet
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For Each ws In Worksheets
If ws.Name Like "*年级" Then
d.RemoveAll
d1.RemoveAll
With ws
r = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("k3:m" & r).ClearContents
arr = .Range("a3:m" & r)
For i = 1 To UBound(arr)
bj = Mid(arr(i, 5), 2)
For j = 6 To 10
arr(i, 11) = arr(i, 11) + arr(i, j)
Next
If Not d.exists(bj) Then
Set d(bj) = CreateObject("scripting.dictionary")
End If
d(bj)(arr(i, 11)) = d(bj)(arr(i, 11)) + 1
d1(arr(i, 11)) = d1(arr(i, 11)) + 1
Next
For Each aa In d.keys
nn = 1
kk = d(aa).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d(aa)(mm)
d(aa)(mm) = nn
nn = ss + nn
Next
Next
nn = 1
kk = d1.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d1(mm)
d1(mm) = nn
nn = ss + nn
Next
For i = 1 To UBound(arr)
bj = Mid(arr(i, 5), 2)
arr(i, 12) = d(bj)(arr(i, 11))
arr(i, 13) = d1(arr(i, 11))
Next
.Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End If
Next
Application.ScreenUpdating = True
MsgBox "成绩统计完毕！"
End Sub作者: yx2599 时间: 2019-5-24 18:35
虽然看上去像个小姐.但还是感谢楼主分享作者: www1234 时间: 2019-5-24 19:32
谢谢楼主分享作者: chlccc 时间: 2019-5-24 22:11
非常棒！谢谢分享！作者: jy_dl 时间: 2019-5-25 00:21
感谢楼主分享作者: ming1986428 时间: 2019-5-25 12:27
妹子不错，感谢楼主分享作者: wq3693963 时间: 2019-5-25 13:20
谢谢楼主分享作者: wzlsss 时间: 2019-5-25 14:11
谢谢楼主，辛苦了作者: pz3578 时间: 2019-5-25 14:17
谢谢楼主分享作者: twb1986 时间: 2019-5-25 23:49
貌似还是可以的作者: xb887766 时间: 2019-5-26 07:57
这个看起来还不错，谢谢分享作者: p9876554 时间: 2019-5-26 07:58
谢谢楼主分享作者: dandybjd 时间: 2019-5-26 09:11
