请教如何使用VBA把七年级工作表里的各科成绩按照初一各校各科平均分的各项要求统计...

cai2532 · 发表于 2022-12-4 11:47

本帖最后由 cai2532 于 2022-12-4 11:49 编辑

"请教如何使用VBA把七年级工作表里的各科成绩按照初一各校各科平均分的各项要求统计出总分和各单科学科的平均分等一分四率人数统计出来放在本表各项单元格里，谢谢！
"

3190496160 · 发表于 2022-12-4 12:42

Sub 分析成绩()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("七年级")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 3 Then MsgBox "成绩表为空！": End
ar = .Range("a2:s" & r)
End With
For I = 2 To UBound(ar)
If Trim(ar(I, 1)) <> "" Then
      d(Trim(ar(I, 1))) = ""
End If
Next I
Dim br()
ReDim br(1 To d.Count, 1 To 82)
For Each K In d.keys
n = n + 1
br(n, 1) = K
zf = 0
For I = 2 To UBound(ar)
      If Trim(ar(I, 1)) = K Then
         If Trim(ar(I, 4)) <> "" Then
            If IsNumeric(ar(I, 4)) Then
                  br(n, 2) = br(n, 2) + 1
                  zf = zf + ar(I, 4)
                  If Trim(ar(I, 5)) = "A" Then
                     br(n, 5) = br(n, 5) + 1
                  End If
                  If Trim(ar(I, 5)) = "B" Then
                     br(n, 7) = br(n, 7) + 1
                  End If
                  If Trim(ar(I, 5)) = "C" Then
                     br(n, 9) = br(n, 9) + 1
                  End If
                  If Trim(ar(I, 5)) = "D" Then
                     br(n, 11) = br(n, 11) + 1
                  End If
            End If
         End If
      End If
Next I
br(n, 3) = zf / br(n, 2)
br(n, 6) = br(n, 5) / br(n, 2)
br(n, 8) = br(n, 7) / br(n, 2)
br(n, 10) = br(n, 9) / br(n, 2)
br(n, 12) = br(n, 11) / br(n, 2)
lh = 13
For J = 6 To UBound(ar, 2) - 1 Step 2
      zfF = 0
      For I = 2 To UBound(ar)
         If Trim(ar(I, 1)) = K Then
            zfF = zfF + ar(I, J)
            If Trim(ar(I, J + 1)) = "A" Then
                  br(n, lh + 2) = br(n, lh + 2) + 1
            End If
            If Trim(ar(I, J + 1)) = "B" Then
                  br(n, lh + 4) = br(n, lh + 4) + 1
            End If
            If Trim(ar(I, J + 1)) = "C" Then
                  br(n, lh + 6) = br(n, lh + 6) + 1
            End If
            If Trim(ar(I, J + 1)) = "D" Then
                  br(n, lh + 8) = br(n, lh + 8) + 1
            End If
         End If
      Next I
      br(n, lh) = zfF / br(n, 2)
      br(n, lh + 3) = br(n, lh + 2) / br(n, 2)
      br(n, lh + 5) = br(n, lh + 4) / br(n, 2)
      br(n, lh + 7) = br(n, lh + 6) / br(n, 2)
      br(n, lh + 9) = br(n, lh + 8) / br(n, 2)
      lh = lh + 10
Next J
Next K
With Sheets("初一各校各科平均分")
.UsedRange.Offset(3) = Empty
.[a4].Resize(n, UBound(br, 2)) = br
.Select
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2022-12-4 12:43

结果未经核对，代码仅供参考
各类排名的代码没有写

学生成绩录入表.rar (29.21 KB, 下载次数: 10)

cai2532 · 发表于 2022-12-4 12:46

3190496160 发表于 2022-12-4 12:43
结果未经核对，代码仅供参考
各类排名的代码没有写

非常感谢，先下载试试看。

cai2532 · 发表于 2022-12-4 14:32

3190496160 发表于 2022-12-4 12:43
结果未经核对，代码仅供参考
各类排名的代码没有写

能否不用增加总分和总分等级这两列也能统计出总分的一分四率？

3190496160 · 发表于 2022-12-4 20:18

本帖最后由 3190496160 于 2022-12-4 20:19 编辑

cai2532 发表于 2022-12-4 14:32
能否不用增加总分和总分等级这两列也能统计出总分的一分四率？

弄一下总分及等级很麻烦吗？啥事儿都让别人帮你做了，你还作甚呢？

chxw68 · 发表于 2022-12-5 09:35

Sub test()
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
With Worksheets("七年级")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(r - 1, c)
End With
n = 3
d1("总分") = n
For j = 4 To UBound(arr, 2) Step 2
n = n + 10
d1(arr(1, j)) = n
Next
ls = 2 + d1.Count * 10
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To ls)
brr(1) = arr(i, 1)
Else
brr = d(arr(i, 1))
End If
brr(2) = brr(2) + 1
s = 0
For j = 4 To UBound(arr, 2) - 1 Step 2
n = d1(arr(1, j))
s = s + arr(i, j)
brr(n) = brr(n) + arr(i, j)
If arr(i, j + 1) = "A" Then
brr(n + 2) = brr(n + 2) + 1
ElseIf arr(i, j + 1) = "B" Then
brr(n + 4) = brr(n + 4) + 1
ElseIf arr(i, j + 1) = "C" Then
brr(n + 6) = brr(n + 6) + 1
Else
brr(n + 8) = brr(n + 8) + 1
End If
Next
brr(3) = brr(3) + s
If s >= 646 Then
brr(5) = brr(5) + 1
ElseIf s >= 570 Then
brr(7) = brr(7) + 1
ElseIf s >= 456 Then
brr(9) = brr(9) + 1
Else
brr(11) = brr(11) + 1
End If
d(arr(i, 1)) = brr
Next
ReDim crr(1 To d.Count, 1 To ls)
m = 0
For Each aa In d.keys
brr = d(aa)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
Next
d.RemoveAll
For i = 1 To UBound(crr)
If Len(crr(i, 2)) <> 0 And crr(i, 2) <> 0 Then
For j = 3 To UBound(crr, 2) Step 10
crr(i, j) = Application.Round(crr(i, j) / crr(i, 2), 2)
crr(i, j + 3) = Application.Round(crr(i, j + 2) / crr(i, 2), 4)
crr(i, j + 5) = Application.Round(crr(i, j + 4) / crr(i, 2), 4)
crr(i, j + 7) = Application.Round(crr(i, j + 6) / crr(i, 2), 4)
crr(i, j + 9) = Application.Round(crr(i, j + 8) / crr(i, 2), 4)
Next
End If
d(crr(i, 3)) = d(crr(i, 3)) + 1
For j = 3 To UBound(crr, 2)
If crr(i, j) = 0 Then
crr(i, j) = Empty
End If
Next
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 = 1 To UBound(crr)
crr(i, 4) = d(crr(i, 3))
Next
With Worksheets("初一各校各科平均分")
With .Range("a1")
.UnMerge
.Resize(1, UBound(crr, 2)).Merge
End With
.UsedRange.Offset(1, 0).Clear
.Range("a2:b2") = Array("学校", "人数")
For j = 1 To 2
.Cells(2, j).Resize(2, 1).Merge
Next
n = 3
For Each aa In d1.keys
With .Cells(2, n)
.Value = aa
.Resize(1, 10).Merge
End With
.Cells(3, n).Resize(1, 10) = Array("平均分", "排名", "A人数", "A率", "B人数", "B率", "C人数", "C率", "D人数", "D率")
n = n + 10
Next
With .Range("a4").Resize(UBound(crr), UBound(crr, 2))
.Value = crr
End With
With .Range("a2").Resize(2 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
End With
For j = 3 To UBound(crr, 2) Step 10
.Columns(j + 3).NumberFormatLocal = "0.00%"
.Columns(j + 5).NumberFormatLocal = "0.00%"
.Columns(j + 7).NumberFormatLocal = "0.00%"
.Columns(j + 9).NumberFormatLocal = "0.00%"
Next
.Columns(1).Resize(, UBound(crr, 2)).AutoFit
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2022-12-5 09:35

练练练手。

cai2532 · 发表于 2022-12-5 10:29

chxw68 发表于 2022-12-5 09:35
练练练手。

真的万分感谢！有心了！

chxw68 · 发表于 2022-12-5 10:31

cai2532 发表于 2022-12-5 10:29
真的万分感谢！有心了！

按常规应该增加一个各科分数等级表，这样的话后期变动就比较方便了。

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

[求助] 请教如何使用VBA把七年级工作表里的各科成绩按照初一各校各科平均分的各项要求统计...