请帮忙做个统计成绩表

一棵小草123 · 发表于 2018-3-21 21:01

月考在即，请各位老师帮个大忙，用VBA解决我们年段成绩统计问题，感谢万分。

chxw68 · 发表于 2018-3-21 21:13

工作量不小！

2801959927 · 发表于 2018-3-21 21:18

嗯嗯太复杂了

abc123281 · 发表于 2018-3-21 21:20

要求太多了

標準中國語 · 发表于 2018-3-21 21:27

建议二维表转成一维表，然后用数据透视表做

一棵小草123 · 发表于 2018-3-21 21:28

辛苦各位老师，大家齐心协力帮下忙，我们老师的电脑太旧了，运行起公式就和蜗牛一样啊！

chxw68 · 发表于 2018-3-21 22:28

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With Worksheets("成绩输入")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:l" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 7)
For i = 1 To UBound(arr)
brr(i, 1) = arr(i, 1)
For j = 4 To UBound(arr, 2)
brr(i, 2) = brr(i, 2) + arr(i, j)
Next
For j = 4 To 6
brr(i, 4) = brr(i, 4) + arr(i, j)
Next
brr(i, 4) = brr(i, 4) + arr(i, 8) * 0.6 + arr(i, 9) * 0.4
brr(i, 3) = brr(i, 4)
For Each y In Array(7, 10, 11, 12)
If arr(i, y) >= 85 Then
brr(i, 3) = brr(i, 3) + 5
ElseIf arr(i, y) >= 75 Then
brr(i, 3) = brr(i, 3) + 2
End If
Next
Next
For j = 2 To 4
d.RemoveAll
For i = 1 To UBound(arr)
d(brr(i, j)) = d(brr(i, j)) + 1
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(arr)
brr(i, j + 3) = d(brr(i, j))
Next
Next
d.RemoveAll
For j = 5 To 7
If Not d.exists(j) Then
Set d(j) = CreateObject("scripting.dictionary")
End If
For i = 1 To UBound(brr)
If Not d(j).exists(brr(i, 1)) Then
ReDim crr(1 To 24)
crr(1) = brr(i, 1)
crr(2) = "班"
Else
crr = d(j)(brr(i, 1))
End If
n = Application.Match(brr(i, j), Array(0, 16, 31, 46, 61, 76, 91, 106, 121, 136, 151, 181, 211, 241, 271, 301, 331, 361, 401, 451, 501, 551, 601))
If Not IsError(n) Then
crr(n + 2) = crr(n + 2) + 1
End If
d(j)(brr(i, 1)) = crr
Next
Next
For Each aa In d.keys
ReDim brr(1 To d(aa).Count, 1 To 24)
m = 0
For Each bb In d(aa).keys
m = m + 1
crr = d(aa)(bb)
For j = 4 To UBound(crr)
crr(j) = crr(j) + crr(j - 1)
Next
For j = 1 To UBound(crr)
brr(m, j) = crr(j)
Next
Next
d(aa) = brr
Next
q = 0
With Worksheets("班总分排名")
.Cells.Clear
m = 1
For Each aa In d.keys
q = q + 1
brr = d(aa)
With .Cells(m, 1)
.Value = "九年级第一次月考" & Application.Choose(q, "班级总分", "加权A总分", "加权B总分") & "排名表"
.Resize(1, 24).Merge
With .Font
.Size = 20
.Bold = True
End With
End With
.Cells(m + 1, 1).Resize(1, 24) = [{" 前若干名","","15名","30名","45名","60名","75名","90名","105名","120名","135名","150名","180名","210名","240名","270名","300名","330名","360名","400名","450名","500名","550名","600名"}]
.Cells(m + 2, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
With .Cells(m + 1, 1).Resize(UBound(brr) + 1, 24)
.Borders.LineStyle = xlContinuous
End With
m = m + UBound(brr) + 3
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
MsgBox "数据统计完毕！"
End Sub

复制代码

chxw68 · 发表于 2018-3-21 22:29

最近很忙，只写了班总分排名统计，算是抛砖引玉吧。

chxw68 · 发表于 2018-3-22 08:33

Sub test2()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
fs = [{0,60,75,85}]
dj = [{"D",0;"C",0;"B",2;"A",5}]
With Worksheets("总分名次A")
c = .Cells(3, .Columns.Count).End(xlToLeft).Column
bt = .Range("a2").Resize(2, c)
For j = 1 To UBound(bt, 2)
If Len(bt(1, j)) <> 0 Then
d1(bt(1, j)) = j
End If
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
ReDim brr(1 To UBound(arr) - 1, 1 To UBound(bt, 2))
For j = 1 To UBound(arr, 2)
If d1.exists(arr(1, j)) Then
n = d1(arr(1, j))
For i = 2 To UBound(arr)
brr(i - 1, n) = arr(i, j)
Next
End If
Next
For j = 19 To 34 Step 5
For i = 1 To UBound(brr)
If Len(brr(i, j)) <> 0 Then
n = Application.Match(brr(i, j), fs)
If Not IsError(n) Then
brr(i, j + 3) = dj(n, 1)
brr(i, j + 4) = dj(n, 2)
End If
End If
Next
Next
For i = 1 To UBound(brr)
For j = 4 To 16 Step 3
brr(i, 39) = brr(i, 39) + brr(i, j)
Next
For j = 19 To 34 Step 5
brr(i, 39) = brr(i, 39) + brr(i, j)
Next
For j = 4 To 10 Step 3
brr(i, 42) = brr(i, 42) + brr(i, j)
Next
brr(i, 42) = brr(i, 42) + brr(i, 13) * 0.6 + brr(i, 16) * 0.4
For j = 19 To 34 Step 5
brr(i, 42) = brr(i, 42) + brr(i, j + 4)
Next
Next
For j = 4 To 42
If Len(bt(1, j)) <> 0 Then
d.RemoveAll
d1.RemoveAll
For i = 1 To UBound(brr)
If Len(brr(i, j)) <> 0 Then
If Not d.exists(brr(i, 1)) Then
Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(brr(i, 1))(brr(i, j)) = d(brr(i, 1))(brr(i, j)) + 1
d1(brr(i, j)) = d1(brr(i, j)) + 1
End If
Next
For Each aa In d.keys
nn = 1
kk = d(aa).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d(aa)(mm)
d(aa)(mm) = nn
nn = nn + ss
Next
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(brr)
If Len(brr(i, j)) <> 0 Then
brr(i, j + 1) = d(brr(i, 1))(brr(i, j))
brr(i, j + 2) = d1(brr(i, j))
End If
Next
End If
Next
With Worksheets("总分名次A")
.Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
r = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range("a2:av" & r)
.Borders.LineStyle = xlContinuous
With .Font
.Size = 9
End With
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-3-22 08:34

做了总分名次A的代码。

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

[求助] 请帮忙做个统计成绩表

评分

评分

评分

最新热点 /1