|
|
Sub 成绩分析()
Application.ScreenUpdating = False
Dim ar As Variant, dr As Variant
Dim d As Object
Dim br(), cr()
Set d = CreateObject("scripting.dictionary")
dr = Sheets("参数表").Range("a2:l2")
With Sheets("原始成绩")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "原始成绩为空！": End
ar = .Range("a2:l" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
gs = Len(Trim(ar(i, 3)))
zd = Mid(Trim(ar(i, 3)), 4, gs - 4)
d(zd) = ""
End If
Next i
ReDim cr(1 To d.Count + 2, 1 To 37)
cr(1, 1) = "年级": cr(1, 2) = "班级": cr(1, 3) = "参评人数"
cr(2, 4) = "总分上线人数": cr(2, 5) = "总分上线率": cr(1, 4) = "总分"
m = 2
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, 3)) <> "" Then
nj = Left(Trim(ar(i, 3)), 3)
gs = Len(Trim(ar(i, 3)))
zd = Mid(Trim(ar(i, 3)), 4, gs - 4)
If zd = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
End If
Next i
m = m + 1
cr(m, 1) = nj
cr(m, 2) = k
cr(m, 3) = n
lh = UBound(ar, 2)
zf = dr(1, lh)
yy = 2
For i = 1 To n
If br(i, lh) <> "" Then
If IsNumeric(br(i, lh)) Then
If br(i, lh) >= zf Then
cr(m, 4) = cr(m, 4) + 1
End If
End If
End If
Next i
For j = 4 To lh - 1
yy = yy + 4
cr(1, yy) = ar(1, j)
cr(2, yy) = "单科上线人数"
cr(2, yy + 1) = "双科上线人数"
cr(2, yy + 2) = "贡献率"
cr(2, yy + 3) = "命中率"
For i = 1 To n
zfrs = 0 ''总分上线人数
dkrs = 0 ''单科上线人数
If br(i, lh) <> "" Then
If IsNumeric(br(i, lh)) Then
If br(i, lh) >= zf Then
zfrs = zfrs + 1
End If
End If
End If
dkfs = dr(1, j)
If br(i, j) <> "" Then
If IsNumeric(br(i, j)) Then
If br(i, j) >= dkfs Then
cr(m, yy) = cr(m, yy) + 1
dkrs = dkrs + 1
End If
End If
End If
If dkrs > 0 And zfrs > 0 Then
cr(m, yy + 1) = cr(m, yy + 1) + 1
End If
Next i
Next j
Next k
For i = 3 To m
If cr(i, 4) <> "" Then
cr(i, 5) = ar(i, 4) / cr(i, 3)
Else
cr(i, 5) = 0
End If
Next i
For j = 8 To 36 Step 4
For i = 3 To m
If cr(i, 4) = "" Then
cr(i, j) = 0
cr(i, j + 1) = 0
Else
cr(i, j) = cr(i, j - 1) / cr(i, 4)
End If
If cr(i, j - 2) = "" Then
cr(i, j + 1) = 0
Else
cr(i, j + 1) = cr(i, j - 1) / cr(i, j - 2)
End If
Next i
Next j
With Sheets("总汇")
.UsedRange = Empty
.[a2].Resize(m, UBound(cr, 2)) = cr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-1-26 22:34
楼主
