如何将各年级各成绩汇总到总表中

chxw68 · 发表于 2017-1-23 16:23

jacking03 发表于 2017-1-23 15:08
说明:1.语文120以上为A，105分以上为B，90分以上为C,90分以下为D。其他各科分值150分的，127.5为A，其他一 ...

不清楚各年级各科满分是多少。

chxw68 · 发表于 2017-1-23 16:29

你把总表中的“参数表”填写完整，就是等级分数段的分数。

jacking03 · 发表于 2017-1-23 17:03

本帖最后由 jacking03 于 2017-1-23 17:16 编辑

年级科目 A B C D
七年级语文 80 70 60 0
数学 85 70 60 0
英语 85 70 60 0
物理 0 0 0 0
化学 0 0 0 0
生物 85 70 60 0
政治 85 70 60 0
历史 85 70 60 0
地理 85 70 60 0
八年级语文 120 105 90 0
数学 127.5 105 90 0
英语 127.5 105 90 0
物理 85 70 60 0
化学 0 0 0 0
生物 85 70 60 0
政治 85 70 60 0
历史 85 70 60 0
地理 85 70 60 0
九年级语文 120 105 90 0
数学 127.5 105 90 0
英语 127.5 105 90 0
物理 85 70 60 0
化学 85 70 60 0
生物 85 70 60 0
政治 85 70 60 0
历史 0 0 0 0
地理 0 0 0 0

jacking03 · 发表于 2017-1-23 17:19

年级科目 A B C D
七年级语文 80 70 60 0
数学 85 70 60 0
英语 85 70 60 0
物理
化学
生物 85 70 60 0
政治 85 70 60 0
历史 85 70 60 0
地理 85 70 60 0
八年级语文 120 105 90 0
数学 127.5 105 90 0
英语 127.5 105 90 0
物理 85 70 60 0
化学
生物 85 70 60 0
政治 85 70 60 0
历史 85 70 60 0
地理 85 70 60 0
九年级语文 120 105 90 0
数学 127.5 105 90 0
英语 127.5 105 90 0
物理 85 70 60 0
化学 63.5 52.5 45 0
生物 85 70 60 0
政治 85 70 60 0
历史 85 70 60 0
地理 85 70 60 0

jacking03 · 发表于 2017-1-23 18:31

七年级各科都是100分制，只有语文80分A，其余都是85分为A；
八九年级语数英是150分，，只有语文120分A,数学英语127.5A，，，其余各科均为100分，85分A，，
九年级化学满分75分，63.5为A，52.5为B，45为C

jacking03 · 发表于 2017-1-23 18:32

现在还无法上传附件，望老师海涵赐教

chxw68 · 发表于 2017-1-23 19:05

Sub test2()
Dim r%, i%
Dim arr, brr
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
Dim d As Object
tt = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set dcs = CreateObject("scripting.dictionary")
With Worksheets("参数表")
r = .Cells(.Rows.Count, 2).End(xlUp).Row
arr = .Range("a1:f" & r)
For i = 2 To UBound(arr)
If Len(arr(i, 1)) <> 0 Then
nj = arr(i, 1)
End If
If Not dcs.exists(nj) Then
Set dcs(nj) = CreateObject("scripting.dictionary")
End If
dcs(nj)(arr(i, 2)) = Array(arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
Next
End With
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls")
With Worksheets("sheet1")
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
bt = .Range("a1").Resize(1, c)
For j = 1 To UBound(bt, 2)
d1(bt(1, j)) = j
Next
End With
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
Set wb = GetObject(mypath & myname)
With wb
With .Worksheets(1)
r = .Cells(.Rows.Count, 1).End(xlUp).Row
If r > 1 And .Range("a1") = "年级" And d1.exists(.Range("g1").Value) Then
arr = .Range("a1:g" & r)
n = d1(arr(1, 7))
For i = 2 To UBound(arr)
If Len(arr(i, 3)) <> 0 Then
If Not d.exists(CStr(arr(i, 3))) Then
ReDim brr(1 To d1.Count)
For j = 1 To 6
brr(j) = arr(i, j)
Next
Else
brr = d(CStr(arr(i, 3)))
End If
brr(n) = arr(i, 7)
d(CStr(arr(i, 3))) = brr
End If
Next
End If
End With
.Close False
End With
End If
myname = Dir
Loop
With Worksheets("sheet1")
.UsedRange.Offset(1, 0).Clear
arr = Application.Transpose(Application.Transpose(d.items))
For i = 1 To UBound(arr)
d1.RemoveAll
If dcs.exists(arr(i, 1)) Then
For j = 7 To 25 Step 2
If Len(arr(i, j)) <> 0 Then
arr(i, 27) = arr(i, 27) + arr(i, j)
If dcs(arr(i, 1)).exists(bt(1, j)) Then
brr = dcs(arr(i, 1))(bt(1, j))
n = 69 - Application.Match(arr(i, j), brr, 1)
arr(i, j + 1) = Chr(n)
d1(arr(i, j + 1)) = d1(arr(i, j + 1)) + 1
End If
End If
Next
End If
If d1.Count > 0 Then
ss = ""
For Each x In Array("A", "B", "C", "D")
If d1.exists(x) Then
ss = ss & d1(x) & x
End If
Next
arr(i, 26) = ss
End If
Next
.Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
.Range("a1:ad" & UBound(arr) + 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox "数据提取统计完毕！共用时" & Timer - tt & "秒"
End With
End Sub

复制代码

chxw68 · 发表于 2017-1-23 19:05

修改好了。

chxw68 · 发表于 2017-1-23 20:57

修改了一下参数表格式。

jacking03 · 发表于 2017-1-23 21:23

感谢chxw68 老师，让您费心了。下载使用发现运行到 arr(i, 27) = arr(i, 27) + arr(i, j)出错了

是不是因为改了格式呢

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

[求助] 如何将各年级各成绩汇总到总表中

最新热点 /1

[求助] 如何将各年级各成绩 汇总到总表中

最新热点 /1

[求助] 如何将各年级各成绩汇总到总表中