从总成绩表中提取获奖名单

yellowhawk · 发表于 2019-10-21 23:34

本帖最后由 yellowhawk 于 2019-10-22 11:27 编辑

我想从总成绩表中按要求提取获奖名单，请各位高手指导！
总表中的L、M、N列是我筛选的辅助列。

liulang0808 · 发表于 2019-10-22 08:44

供参考。。。。。。

约定的童话 · 发表于 2019-10-22 08:46

一个人还能多次获奖啊？

chxw68 · 发表于 2019-10-22 08:56

Sub test()
Dim r%, i%, m%, x%
Dim arr, brr
Dim d As Object
Dim flg As Boolean
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("总表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:k" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 2 To UBound(arr)
If Len(arr(i, 11)) <> 0 Then
d(arr(i, 11)) = d(arr(i, 11)) + 1
End If
Next
nn = 1
kk = d.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d(mm)
d(mm) = nn
nn = nn + ss
Next
For i = 2 To UBound(arr)
If Len(arr(i, 11)) <> 0 Then
brr(i, 1) = d(arr(i, 11))
End If
n = 0
For j = 3 To 9
If Len(arr(i, j)) <> 0 Then
n = n + 1
brr(i, 2) = brr(i, 2) + arr(i, j)
If IsEmpty(brr(i, 3)) Then
brr(i, 3) = arr(i, j)
Else
If brr(i, 3) > arr(i, j) Then
brr(i, 3) = arr(i, j)
End If
End If
End If
Next
If n <> 0 Then
brr(i, 2) = Round(brr(i, 2) / n, 2)
End If
Next
d.RemoveAll
ywmax = Application.Max(Application.Index(arr, 0, 4))
For i = 2 To UBound(arr)
If brr(i, 1) <= 10 Then
If Not d.exists("一类") Then
m = 1
ReDim crr(1 To 12, 1 To m)
Else
crr = d("一类")
m = UBound(crr, 2) + 1
ReDim Preserve crr(1 To 12, 1 To m)
End If
For j = 1 To 11
crr(j, m) = arr(i, j)
Next
If brr(i, 1) = 1 Then
crr(12, m) = "学神奖"
Else
crr(12, m) = "学霸奖"
End If
d("一类") = crr
End If
For j = 3 To 9
flg = False
Select Case arr(1, j)
Case "语文"
If arr(i, j) = ywmax And arr(i, j) >= 135 Then
flg = True
End If
Case "数学", "英语"
If arr(i, j) = 120 Then
flg = True
End If
Case Else
If arr(i, j) = 100 Then
flg = True
End If
End Select
If flg Then
If Not d.exists("二类") Then
m = 1
ReDim crr(1 To 13, 1 To m)
Else
crr = d("二类")
m = UBound(crr, 2) + 1
ReDim Preserve crr(1 To 13, 1 To m)
End If
For k = 1 To 11
crr(k, m) = arr(i, k)
Next
crr(12, m) = arr(1, j) & "单科王"
crr(13, m) = j
d("二类") = crr
End If
Next
x = -1
If brr(i, 2) >= 90 And brr(i, 3) >= 80 Then
x = 1
ElseIf brr(i, 2) >= 85 And brr(i, 3) >= 70 Then
x = 2
ElseIf brr(i, 2) >= 80 And brr(i, 3) >= 60 Then
x = 3
ElseIf brr(i, 2) >= 70 And brr(i, 3) >= 60 Then
x = 4
End If
If x <> -1 Then
If Not d.exists("三类") Then
m = 1
ReDim crr(1 To 13, 1 To m)
Else
crr = d("三类")
m = UBound(crr, 2) + 1
ReDim Preserve crr(1 To 13, 1 To m)
End If
For k = 1 To 11
crr(k, m) = arr(i, k)
Next
crr(12, m) = Application.Choose(x, "一等奖", "二等奖", "三等奖", "优秀奖")
crr(13, m) = x
d("三类") = crr
End If
Next
With Worksheets("获奖名单")
.UsedRange.Offset(2, 0).Clear
.Select
m = 3
For Each aa In Array("一类", "二类", "三类")
If d.exists(aa) Then
crr = d(aa)
ReDim drr(1 To UBound(crr, 2), 1 To UBound(crr))
For i = 1 To UBound(crr)
For j = 1 To UBound(crr, 2)
drr(j, i) = crr(i, j)
Next
Next
Select Case aa
Case "一类"
.Cells(m, 1) = "一类：第一名为学神奖，第二至十名为学霸奖"
Case "二类"
.Cells(m, 1) = "二类：单科王，语文成绩大于135分且为第一名为单科王，其他科目为满分为才为单科王，数学、英语总分120，其他科目100，体育不计"
Case "三类"
.Cells(m, 1) = "三类：一等奖科平均分90分，最低分大于等于80的；二等奖科平85分以上，最低分70的；三等奖科平80的，最低分60；优秀奖科平70，最低分60"
End Select
With .Cells(m + 1, 1).Resize(UBound(drr), UBound(drr, 2))
.Value = drr
Select Case aa
Case "一类"
.Sort key1:=.Cells(m + 1, 11), order1:=xlDescending, Header:=xlNo
Case "二类", "三类"
.Sort key1:=.Cells(m + 1, 13), order1:=xlAscending, Header:=xlNo
End Select
End With
m = m + UBound(drr) + 1
End If
Next
.Columns(13).Clear
End With
Application.ScreenUpdating = True
MsgBox "成绩统计完毕！"
End Sub

复制代码

chxw68 · 发表于 2019-10-22 08:57

详见附件。

yellowhawk · 发表于 2019-10-22 11:22

约定的童话发表于 2019-10-22 08:46
一个人还能多次获奖啊？

当然是可以的，既是学霸，也是单科王，这应该是可以的呀

yellowhawk · 发表于 2019-10-22 11:23

chxw68 发表于 2019-10-22 08:57
详见附件。

非常感谢您的指导！

yellowhawk · 发表于 2019-10-22 11:23

liulang0808 发表于 2019-10-22 08:44
供参考。。。。。。

非常感谢您的指导！！！！！

yellowhawk · 发表于 2019-10-22 11:31

chxw68 发表于 2019-10-22 08:56

要写了这么多，辛苦您了！

yellowhawk · 发表于 2019-10-22 14:36

chxw68 发表于 2019-10-22 08:56

刚才试了一下，如果没有参加考试的成绩为空，也会列入学霸奖中，我看了一下，原因是
If brr(i, 1) <= 10 Then
   If Not d.exists("一类") Then
      m = 1
<=10,这里，应该还要大于0
是否可以奖这一句 If brr(i, 1) <= 10 Then
改为：
   if brr(i,1)<=10 and brr(i,1)>0 then
(我是初学者，错了别笑我！）

		自动登录	找回密码
密码			免费注册

[已解决] 从总成绩表中提取获奖名单

评分

评分

最新热点 /1