请教，如何一键提取各班成绩（不在同一列）至一个表，然后进行排名汇总？

renkangjizhen · 发表于 2019-6-3 10:47

都是大师级别的高手！佩服！

gery_1 · 发表于 2019-6-3 14:26

本帖最后由 gery_1 于 2019-6-5 13:36 编辑

zpy2 发表于 2019-5-22 19:51
哦，我这个不是vba的，是在线php和数据库的，我意思是各班成绩整理到一张表，就可以用一条sql语句进行排 ...

web.7z (1.99 MB, 下载次数: 4)
我从phpcj（https://phpcj.net/）下载了一个网站源码，感觉不错，但是经过更改后总是出错，1.“学生个人成绩查询”总是出错2.“修改成绩数据”不显示上传数据，请老师帮助改改，谢谢。微信图片_20190603142339.png

gery_1 · 发表于 2019-6-4 09:48

gery_1 发表于 2019-6-3 14:26
我从phpcj（https://phpcj.net/）下载了一个网站源码，感觉不错，但是经过更改后总是出错，1.“学生个人 ...

这个网站原先只有初中高中，自从被我胡乱修改后，添加了1-6年级，但是也就出现了上面的问题。

gery_1 · 发表于 2019-6-5 13:25

本帖最后由 gery_1 于 2019-6-5 13:31 编辑

5年级-期中成绩2019.5.7 -.zip (95.08 KB, 下载次数: 8)

1.添加“蓝桥玄霜”老师的vba代码后后，这个表修复了年级一键汇总功能（能自动从各班级提取学生姓名、各科成绩并自动进行汇总排名）。

微信图片_20190605131334.png

2.又添加了各科最高分、最低分、数值输错自动染色功能。

微信图片_20190605131331.png

3.提取年级前N名还是有毛病.

4.一键提取各科前N名，存在错误。

请各位老师帮助修改一下，谢谢！

gery_1 · 发表于 2019-6-11 16:41

修改完善20190611附件：

5年级-期中成绩2019.5.7 -.zip (94.64 KB, 下载次数: 43)

zpy2 · 发表于 2019-6-13 12:19

gery_1 发表于 2019-6-4 09:48
这个网站原先只有初中高中，自从被我胡乱修改后，添加了1-6年级，但是也就出现了上面的问题。

这个代码比较多，我一时也看不出来啥问题，你咋修改的，一般都是牵一发而动全身的。

zpy2 · 发表于 2019-6-13 13:18

gery_1 发表于 2019-6-3 14:26
我从phpcj（https://phpcj.net/）下载了一个网站源码，感觉不错，但是经过更改后总是出错，1.“学生个人 ...

这种也可以查询的，按角色，查询自己的成绩。

chxw68 · 发表于 2019-6-13 15:25

Sub test1()
Dim r%, i%
Dim arr, brr(1 To 10000, 1 To 10)
Dim reg As New RegExp
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With reg
.Global = False
.Pattern = "^\d\.\d{1,2}$"
End With
m = 0
For Each ws In Worksheets
If reg.test(ws.Name) Then
With ws
arr = .Range("a2:j41")
For j = 1 To 6 Step 5
For i = 1 To IIf(j = 1, 40, 19)
If Len(arr(i, j + 1)) <> 0 Then
m = m + 1
brr(m, 1) = ws.Name
brr(m, 3) = arr(i, j + 1)
brr(m, 4) = arr(i, j + 2)
brr(m, 5) = arr(i, j + 3)
brr(m, 6) = arr(i, j + 4)
End If '
Next
Next
End With
End If
Next
For i = 1 To m
For j = 4 To 7
brr(i, 8) = brr(i, 8) + brr(i, j)
Next
d(brr(i, 8)) = d(brr(i, 8)) + 1
If Not d1.exists(brr(i, 1)) Then
Set d1(brr(i, 1)) = CreateObject("scripting.dictionary")
End If
d1(brr(i, 1))(brr(i, 8)) = d1(brr(i, 1))(brr(i, 8)) + 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 Each aa In d1.keys
nn = 1
kk = d1(aa).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d1(aa)(mm)
d1(aa)(mm) = nn
nn = nn + ss
Next
Next
For i = 1 To m
brr(i, 9) = d(brr(i, 8))
brr(i, 10) = d1(brr(i, 1))(brr(i, 8))
Next
With Worksheets("年级总排名")
.UsedRange.Offset(1, 0).ClearContents
.Range("a2").Resize(m, UBound(brr, 2)) = brr
With .Range("a1:j" & m + 1)
With .Font
.Size = 10
.Name = "宋体"
End With
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2019-6-13 15:26

写了一键汇总代码。

chxw68 · 发表于 2019-6-13 15:35

年级前N名

Sub test2()
Dim r%, i%
Dim arr, brr
mc = Application.InputBox(prompt:="请输入要提取成绩的最大名次", Title:="输入提示", Default:=10, Type:=1)
ReDim brr(1 To mc * 2, 1 To 10)
With Worksheets("年级总排名")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:j" & r)
End With
m = 0
For i = 1 To UBound(arr)
If arr(i, 9) <= mc Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
End If
Next
With Worksheets("年级前N名")
.UsedRange.Offset(2, 0).ClearContents
With .Range("a3").Resize(m, UBound(brr, 2))
.Value = brr
.Sort key1:=.Range("i3"), order1:=xlAscending, Header:=xlNo
End With
With .Range("a2").Resize(m + 1, UBound(brr, 2))
With .Font
.Size = 10
.Name = "宋体"
End With
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

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

[求助] 请教，如何一键提取各班成绩（不在同一列）至一个表，然后进行排名汇总？

评分

评分

评分

评分

最新热点 /1