学校月考成绩登分后能一键自动生成各班级的分表，并且总动计算各班级科目的平均分等

18585498166 · 发表于 2018-9-24 22:20

求助：学校月考成绩登完后，年级总表能一键自动生成各班的成绩，并自动在成绩分析这个表中的自动生成各班科目的平均分，各班科目平均分与年级平均分的分差，计算出各班年级前10名，前20名，前30名，50名，100名，150名，200名人数

719404338 · 发表于 2018-9-25 07:15

成绩登分总表没有班级，怎么生成各班成绩？

18585498166 · 发表于 2018-9-25 08:02

719404338 发表于 2018-9-25 07:15
成绩登分总表没有班级，怎么生成各班成绩？

学号那一栏改成班级，不好意思

chxw68 · 发表于 2018-9-25 08:32

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("成绩登分总表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("b1:b" & r)
For i = 2 To UBound(arr)
bj = Left(arr(i, 1), 2)
If Not d.exists(bj) Then
Set d(bj) = .Range("a1").Resize(1, c)
End If
Set d(bj) = Union(d(bj), .Cells(i, 1).Resize(1, c))
Next
End With
For Each aa In d.keys
On Error Resume Next
Set ws = Worksheets(aa)
If Err Then
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = aa
End If
On Error GoTo 0
With Worksheets(aa)
.Cells.Clear
d(aa).Copy .Range("a1")
End With
Next
End Sub

复制代码

chxw68 · 发表于 2018-9-25 08:33

只写了拆分成绩的代码。

chxw68 · 发表于 2018-9-25 09:16

Sub test2()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set djs = CreateObject("scripting.dictionary")
With Worksheets("班级和科任教师参数设置")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For i = 2 To UBound(arr)
Set djs(arr(i, 1)) = CreateObject("scripting.dictionary")
For j = 2 To UBound(arr, 2)
djs(arr(i, 1))(arr(1, j)) = arr(i, j)
Next
Next
For j = 2 To UBound(arr, 2)
d1(arr(1, j)) = j - 1
Next
End With
With Worksheets("成绩登分总表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For i = 2 To UBound(arr)
bj = Left(arr(i, 2), 2)
For j = 4 To UBound(arr, 2)
If d1.exists(arr(1, j)) Then
n = d1(arr(1, j)) * 3 - 1
If Not d.exists(bj) Then
ReDim brr(1 To 1 + d1.Count * 3)
brr(1) = Application.Text(Left(bj, 1), "[DBNum1]") & "（" & Mid(bj, 2, 1) & "）班"
Else
brr = d(bj)
End If
brr(n + 1) = brr(n + 1) + arr(i, j)
brr(n + 2) = brr(n + 2) + 1
d(bj) = brr
End If
Next
Next
brr = Application.Transpose(Application.Transpose(d.items))
ReDim crr(1 To UBound(brr, 2))
crr(1) = "年级平均"
For i = 1 To UBound(brr)
For j = 3 To UBound(brr, 2) Step 3
crr(j) = crr(j) + brr(i, j)
crr(j + 1) = crr(j + 1) + brr(i, j + 1)
Next
If djs.exists(brr(i, 1)) Then
For Each aa In d1.keys
n = d1(aa) * 3 - 1
If djs(brr(i, 1)).exists(aa) Then
brr(i, n) = djs(brr(i, 1))(aa)
End If
Next
End If
Next
For j = 3 To UBound(brr, 2) Step 3
If Len(crr(j + 1)) <> 0 And crr(j + 1) <> 0 Then
crr(j) = Round(crr(j) / crr(j + 1), 2)
End If
For i = 1 To UBound(brr)
If Len(brr(i, j + 1)) <> 0 And brr(i, j + 1) <> 0 Then
brr(i, j) = Round(brr(i, j) / brr(i, j + 1), 2)
End If
brr(i, j + 1) = brr(i, j) - crr(j)
Next
Next
For i = 1 To UBound(brr)
For j = 1 To UBound(brr, 2)
If brr(i, j) = 0 Then
brr(i, j) = ""
End If
Next
Next
For j = 1 To UBound(crr)
If crr(j) = 0 Then
crr(j) = ""
End If
Next
For j = 4 To UBound(crr) Step 3
crr(j) = ""
Next
With Worksheets("sheet1")
.Cells.Clear
.Range("a1") = "班级"
For Each aa In d1.keys
n = d1(aa) * 3 - 1
.Cells(1, n) = aa
.Cells(1, n + 1).Resize(1, 2) = Array("平均分", "分差")
Next
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
.Cells(UBound(brr) + 2, 1).Resize(1, UBound(crr)) = crr
r = UBound(brr) + 2
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("a1").Resize(r, c).Borders.LineStyle = xlContinuous
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-9-25 09:23

增加了计算平均分和分差的代码。

chxw68 · 发表于 2018-9-25 09:32

Sub test3()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
fsd = [{10,30,50,100}]
With Worksheets("成绩登分总表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For i = 2 To UBound(arr)
bj = Left(arr(i, 2), 2)
bj = Application.Text(Left(bj, 1), "[DBNum1]") & "（" & Mid(bj, 2, 1) & "）班"
If Not d.exists(bj) Then
ReDim brr(1 To 5)
brr(1) = bj
Else
brr = d(bj)
End If
For j = 1 To UBound(fsd)
If arr(i, 16) <= fsd(j) Then
brr(j + 1) = brr(j + 1) + 1
End If
Next
d(bj) = brr
Next
With Worksheets("sheet2")
.Cells.Clear
.Range("a1") = "班级"
For j = 1 To UBound(fsd)
.Cells(1, j + 1) = "前" & fsd(j) & "名" & vbLf & "人数"
Next
.Range("a2").Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
r = d.Count + 1
.Range("a1").Resize(r, 5).Borders.LineStyle = xlContinuous
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-9-25 09:33

详见附件。

踏雪访梅 · 发表于 2018-9-25 09:54

用函数处理的，EXCEL2013版，可参考一下。

学校月考成绩统计分析.rar (55.22 KB, 下载次数: 156)

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

[求助] 学校月考成绩登分后能一键自动生成各班级的分表，并且总动计算各班级科目的平均分等

评分

评分

评分

评分

评分

评分

评分

最新热点 /1