求教：如何通过VBA将成绩录入汇总表分拆成各班各科成绩单？谢谢！

yiran7810 · 发表于 2019-1-22 21:48

求教：如何通过VBA将成绩录入汇总表分拆成各班各科成绩单？谢谢！
我发的附件只是部分数据，实际上学生数有几千人，班级上百个。所以希望能用 VBA 来完成。谢谢

micch · 发表于 2019-1-22 21:55

你这是要按B列班序号分表，还是按C列班级分表

yiran7810 · 发表于 2019-1-22 21:57

micch 发表于 2019-1-22 21:55
你这是要按B列班序号分表，还是按C列班级分表

按C列班级分表，谢谢！

micch · 发表于 2019-1-22 22:56

如果是根据录入表，生成其他的表，那工作量就大多了，因为那些统计数据太零碎了。

如果假设各个分表已经做好格式，只是把所有人姓名和分数分到对应的表当中还容易一些，

abc123281 · 发表于 2019-1-22 23:16

很简单得问题楼主是位老师吧
1  求助要求不明白  结果是拆分成工作簿还是放在原工作簿中
2  建议以后求助的同时  也上传想要实现的效果模拟附件
3  就像你所教的小学生一样  你想让学生画一个葫芦  你得先说明要求  再拿出一个实际的葫芦  学生才能照着画  否则学生画出的结果就是  有些像梨  有些像桃子......因为有些学生没见过真正的葫芦

micch · 发表于 2019-1-22 23:40

假设你的分表已经做好，格式也有了，代码直接填入数据；
注意：代码结果和你模拟的结果人名顺序不同，不知道模拟结果是什么顺序。代码执行后代码生成数据会覆盖分表的【a9:p33】区域原来的数据。
如果分表没建立，可以增加一段新建分表的代码，太晚了就不写了。

Sub test()
Dim i%, j%, n%, m%, x$
Set d = CreateObject("scripting.dictionary")
Set dn = CreateObject("scripting.dictionary")
arr = Sheet1.UsedRange
For i = 4 To UBound(arr)
For j = 7 To 13 Step 2
x = Left(Right(arr(i, 3), 2), 1) & Left(arr(3, j), 1)
d(x) = d(x) + 1
x = x & "@" & arr(i, 4)
dn(x) = arr(i, j)
Next j, i
Dim brr(24, 15)
For Each sh In Worksheets
x = sh.Name
If d.exists(x) Then
ar = Filter(dn.keys, x)
Erase brr
For i = 0 To UBound(ar)
n = Int(i / 25) * 4: m = i Mod 25
brr(m, 0 + n) = i + 1
brr(m, 1 + n) = Split(ar(i), "@")(1)
brr(m, 2 + n) = dn(ar(i))
Next
Worksheets(x).[a9:p33] = brr
End If
Next
End Sub

复制代码

chxw68 · 发表于 2019-1-23 02:02

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
hg = [{60,22,22,40,25,29,20,22.5}]
lk = [{5.57,7.71,9,7.71,7.71,9,5.57,9,6.43,9,5.57,5.57}]
Set d = CreateObject("scripting.dictionary")
With Worksheets("成绩录入表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:p" & r)
End With
For i = 2 To UBound(arr)
bj = Val(Split(arr(i, 3), "（")(1))
If Not d.exists(bj) Then
Set d(bj) = CreateObject("scripting.dictionary")
End If
For j = 7 To 13 Step 2
km = Left(arr(1, j), 2)
If Not d(bj).exists(km) Then
m = 1
ReDim brr(1 To 3, 1 To m)
Else
brr = d(bj)(km)
m = UBound(brr, 2) + 1
ReDim Preserve brr(1 To 3, 1 To m)
End If
brr(1, m) = m
brr(2, m) = arr(i, 4)
brr(3, m) = arr(i, j)
d(bj)(km) = brr
Next
Next
For Each aa In d.keys
For Each bb In d(aa).keys
brr = d(aa)(bb)
ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
For i = 1 To UBound(brr)
For j = 1 To UBound(brr, 2)
crr(j, i) = brr(i, j)
Next
Next
ReDim drr(1 To 12)
For i = 1 To UBound(crr)
drr(1) = drr(1) + 1
If Len(crr(i, 3)) <> 0 And IsNumeric(crr(i, 3)) Then
drr(2) = drr(2) + 1
drr(3) = drr(3) + crr(i, 3)
If crr(i, 3) >= 80 Then
drr(5) = drr(5) + 1
End If
If crr(i, 3) >= 60 Then
drr(7) = drr(7) + 1
Else
drr(9) = drr(9) + 1
End If
If IsEmpty(drr(11)) Then
drr(11) = crr(i, 3)
Else
If drr(11) < crr(i, 3) Then
drr(11) = crr(i, 3)
End If
End If
If IsEmpty(drr(12)) Then
drr(12) = crr(i, 3)
Else
If drr(12) > crr(i, 3) Then
drr(12) = crr(i, 3)
End If
End If
End If
Next
If Len(drr(2)) <> 0 And drr(2) <> 0 Then
drr(4) = Round(drr(3) / drr(2), 2)
drr(6) = Round(drr(5) / drr(2), 4)
drr(8) = Round(drr(7) / drr(2), 4)
drr(10) = Round(drr(9) / drr(2), 4)
End If
wjm = aa & Left(bb, 1)
On Error Resume Next
Set ws = Worksheets(wjm)
If Err Then
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = wjm
End If
On Error GoTo 0
With ws
.Cells.Clear
With .Range("a1")
.Value = "海城镇第二小学五年级第一次月考知识测试" & vbLf & "质量分析表"
.Resize(1, 12).Merge
With .Font
.Size = 18
.Bold = True
End With
End With
With .Range("a2")
.Value = "(2018-2019学年度第一学期）"
.Resize(1, 12).Merge
End With
.Range("a3") = "班级"
.Range("b3") = aa
.Range("e3") = "学科"
.Range("f3") = bb
With .Range("j3")
.Value = #10/1/2018#
.Resize(1, 3).Merge
End With
With .Range("a4")
.Value = "应考" & vbLf & "人数"
.Resize(2, 1).Merge
End With
With .Range("b4")
.Value = "实考" & vbLf & "人数"
.Resize(2, 1).Merge
End With
With .Range("c4")
.Value = "总分"
.Resize(2, 1).Merge
End With
With .Range("d4")
.Value = "人平" & vbLf & "均分"
.Resize(2, 1).Merge
End With
With .Range("e4")
.Value = "红分" & vbLf & "(80-100分)"
.Resize(1, 2).Merge
End With
With .Range("g4")
.Value = "及格" & vbLf & "(60-100分)"
.Resize(1, 2).Merge
End With
With .Range("i4")
.Value = "不及格" & vbLf & "(0-59分)"
.Resize(1, 2).Merge
End With
For j = 5 To 9 Step 2
.Cells(5, j).Resize(1, 2) = Array("人数", "%")
Next
With .Range("k4")
.Value = "最" & vbLf & "高" & vbLf & "分"
.Resize(2, 1).Merge
End With
With .Range("l4")
.Value = "最" & vbLf & "低" & vbLf & "分"
.Resize(2, 1).Merge
End With
.Range("a6").Resize(1, 12) = drr
With .Range("a7")
.Value = "学生姓名及分数"
.Resize(1, 12).Merge
End With
For j = 1 To 10 Step 3
.Cells(8, j).Resize(1, 3) = Array("序号", "姓名", "分数")
Next
m = 9
n = 1
For i = 1 To UBound(crr)
.Cells(m, n) = crr(i, 1)
.Cells(m, n + 1) = crr(i, 2)
.Cells(m, n + 2) = crr(i, 3)
m = m + 1
If m > 33 Then
m = 9
n = n + 3
End If
Next
With .Range("a2:l33")
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
.Range("f6,h6,j6").NumberFormatLocal = "0.00%"
For i = 1 To 7
.Rows(i).RowHeight = hg(i)
Next
.Rows("8:33").RowHeight = hg(8)
For j = 1 To UBound(lk)
.Columns(j).ColumnWidth = lk(j)
Next
With .Range("a4:l33")
.Borders.LineStyle = xlContinuous
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Next
Next
End Sub

复制代码

chxw68 · 发表于 2019-1-23 02:04

详见附件。

yiran7810 · 发表于 2019-1-23 08:37

chxw68 发表于 2019-1-23 02:02

谢谢！您的帮助！

micch · 发表于 2019-1-23 09:43

7楼厉害了，完全用代码弄一个表格啊，我还想该做个标准分表，用复制的方式写代码呢

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

[求助] 求教：如何通过VBA将成绩录入汇总表分拆成各班各科成绩单？谢谢！

评分

评分

评分

最新热点 /1