- Sub test2()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Call main
- With Worksheets("录入成绩")
- r = .Cells(.Rows.Count, 4).End(xlUp).Row
- arr = .Range("a2:n" & r)
- End With
- For j = 5 To UBound(arr, 2) - 1
- If Application.Count(Application.Index(arr, 0, j)) > 0 Then
- Set d(arr(1, j)) = CreateObject("scripting.dictionary")
- jq30 = Application.Large(Application.Index(arr, 0, j), 30)
- jq60 = Application.Large(Application.Index(arr, 0, j), 60)
- jh50 = Application.Small(Application.Index(arr, 0, j), 50)
-
- For i = 2 To UBound(arr)
- If Not d(arr(1, j)).exists(arr(i, 2)) Then
- ReDim brr(1 To 23)
- brr(1) = arr(i, 2)
- brr(2) = arr(1, j)
- Else
- brr = d(arr(1, j))(arr(i, 2))
- End If
- brr(3) = brr(3) + 1
- If Len(arr(i, j)) <> 0 Then
- brr(4) = brr(4) + 1
- brr(5) = brr(5) + arr(i, j)
- If arr(i, j) >= dcs(arr(1, j))("C") Then
- brr(7) = brr(7) + 1
- End If
- If arr(i, j) >= dcs(arr(1, j))("B") Then
- brr(10) = brr(10) + 1
- End If
- If arr(i, j) >= dcs(arr(1, j))("A") Then
- brr(13) = brr(13) + 1
- End If
- If IsEmpty(brr(16)) Then
- brr(16) = arr(i, j)
- Else
- If brr(16) < arr(i, j) Then
- brr(16) = arr(i, j)
- End If
- End If
- If IsEmpty(brr(17)) Then
- brr(17) = arr(i, j)
- Else
- If brr(17) > arr(i, j) Then
- brr(17) = arr(i, j)
- End If
- End If
- If arr(i, j) <= dcs(arr(1, j))("满分") * 0.3 Then
- brr(18) = brr(18) + 1
- End If
- If arr(i, j) >= jq30 Then
- brr(21) = brr(21) + 1
- End If
- If arr(i, j) >= jq60 Then
- brr(22) = brr(22) + 1
- End If
- If arr(i, j) <= jh50 Then
- brr(23) = brr(23) + 1
- End If
- End If
- d(arr(1, j))(arr(i, 2)) = brr
- Next
- End If
- Next
- x = 2
- With Worksheets("科分析")
- .UsedRange.Offset(1, 0).Clear
- With .Range("a1")
- .Value = "各科质量分析"
- With .Font
- .Size = 18
- .Bold = True
- End With
- End With
- For Each aa In d.keys
- ReDim crr(1 To d(aa).Count, 1 To UBound(brr))
- ReDim drr(1 To UBound(crr, 2))
- m = 0
- For Each bb In d(aa).keys
- m = m + 1
- brr = d(aa)(bb)
- For j = 1 To UBound(brr)
- crr(m, j) = brr(j)
- Next
- For Each y In Array(3, 4, 5, 7, 10, 13, 18, 21, 22, 23)
- drr(y) = drr(y) + brr(y)
- Next
- Next
- For i = 1 To UBound(crr)
- If Len(crr(i, 4)) <> 0 And crr(i, 4) <> 0 Then
- crr(i, 5) = Round(crr(i, 5) / crr(i, 4), 2)
- crr(i, 8) = Round(crr(i, 7) / crr(i, 4), 4)
- crr(i, 11) = Round(crr(i, 10) / crr(i, 4), 4)
- crr(i, 14) = Round(crr(i, 13) / crr(i, 4), 4)
- crr(i, 19) = Round(crr(i, 18) / crr(i, 4), 4)
- End If
- Next
- For Each y In Array(5, 8, 11, 14)
- d1.RemoveAll
- For i = 1 To UBound(crr)
- If Len(crr(i, y)) <> 0 Then
- d1(crr(i, y)) = d1(crr(i, y)) + 1
- End If
- 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 = nn + ss
- Next
- For i = 1 To UBound(crr)
- If Len(crr(i, y)) <> 0 Then
- crr(i, y + 1) = d1(crr(i, y))
- End If
- Next
- Next
-
- drr(1) = "合计"
- drr(2) = crr(1, 2)
- drr(16) = Application.Max(Application.Index(crr, 0, 16))
- drr(17) = Application.Min(Application.Index(crr, 0, 17))
- If Len(drr(4)) <> 0 And drr(4) <> 0 Then
- drr(5) = Round(drr(5) / drr(4), 2)
- drr(8) = Round(drr(7) / drr(4), 4)
- drr(11) = Round(drr(10) / drr(4), 4)
- drr(14) = Round(drr(13) / drr(4), 4)
- drr(19) = Round(drr(18) / drr(4), 4)
- End If
-
- For i = 1 To UBound(crr)
- crr(i, 20) = crr(i, 5) - drr(5)
- Next
-
- .Cells(x, 1).Resize(1, 23) = Array("班级", "科目", "应考" & vbLf & "人数", "实考" & vbLf & "人数", "平均" & vbLf & "分", "名" & vbLf & "次", "及格" & vbLf & "人数", "及格" & vbLf & "率", "名" & vbLf & "次", "良好" & vbLf & "人数", "良好" & vbLf & "率", "名" & vbLf & "次", "A" & vbLf & "人数", "A率", "名" & vbLf & "次", "最高" & vbLf & "分", "最低" & vbLf & "分", "低分" & vbLf & "人数", "低分" & vbLf & "率", "平均" & vbLf & "相对" & vbLf & "分", "级前" & vbLf & "30名" & vbLf & "(人)", "级前" & vbLf & "60名" & vbLf & "(人)", "级后" & vbLf & "50名" & vbLf & "(人)")
- .Cells(x + 1, 1).Resize(1, UBound(drr)) = drr
- .Cells(x + 2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
- With .Cells(x, 1).Resize(UBound(brr) + 2, 23)
- .Borders.LineStyle = xlContinuous
- End With
- x = x + UBound(crr) + 3
- Next
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- With .Range("a2:w" & r)
- With .Font
- .Size = 10
- End With
- End With
- .Range("h:h,k:k,n:n,s:s").NumberFormatLocal = "0.00%"
- .Columns("a:w").AutoFit
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- End Sub
复制代码 |