考试成绩分析求助

熊文来

zopey 发表于 2018-10-31 15:01
按班级 统计各科成绩

谢谢您在百忙中帮我做这个文件，这个附件是您检查过 没问题的那个附件吗？》

zopey

熊文来 发表于 2018-10-31 15:42
谢谢您在百忙中帮我做这个文件，这个附件是您检查过 没问题的那个附件吗？》

代码部分 我检查过了没有大问题，能够一键运行。
至于统计数据是否可用，需要你要在报表建立公式 检查。

熊文来

zopey 发表于 2018-10-31 15:53
代码部分 我检查过了没有大问题，能够一键运行。
至于统计数据是否可用，需要你要在报表建立公式 检查。 ...

程序有点小问题 可以加你QQ和你沟通吗？

zopey

2007--2010
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & ThisWorkbook.FullName

2003
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & ThisWorkbook.FullName

wfchenyiting

都很厉害啊，慢慢学习了

xiaoqiang17

有时间想试一试看会不会做的，但有的地方看不明白。

熊文来

xiaoqiang17 发表于 2018-11-1 11:32
有时间想试一试看会不会做的，但有的地方看不明白。

文件里有说明，确实要理解我这文件的意图 是要花点时间。不明白的地方和我留言。我每天都会不定时进来的。

一把小刀闯天下

'类似的这帖子你发过。只写了第一个问题的代码，后面2个问题理解起来太费劲，，，

'假设A、B、C列有序，如果无序先手动排序没必要拿代码来排序

'正排名应该为降序排名，你这怎么是升序的。如果确实是这样修改rank函数的上一行：false<->true

Option Explicit

Sub test()
  Dim arr, pos, i, j, k, temp
  pos = Array(6, 7, 8, 9) '语文数学英语总分列号
  With Sheets("起点成绩")
    arr = .Range("a2:s" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
    For i = 1 To UBound(arr, 1) - 1: arr(i, 19) = i: Next '辅助列写入序号
    temp = arr
    Call msort(arr, temp, 2, UBound(arr, 1) - 1, 2, True) '年级升序（所有校区）
    For i = 1 To UBound(arr, 1) - 1
      For j = i To UBound(arr, 1) - 1
        If arr(j, 2) <> arr(j + 1, 2) Then '按年级分段
          For k = 0 To UBound(pos) '正排名
            Call msort(arr, temp, i, j, pos(k), False) '降序
            Call rank(arr, i, j, pos(k), pos(k) + UBound(pos) + 1)
          Next
          For k = 0 To UBound(pos) '倒排名
            Call msort(arr, temp, i, j, pos(k), True) '升序
            Call rank(arr, i, j, pos(k), pos(k) + (UBound(pos) + 1) * 2)
          Next
          i = j: Exit For
        End If
    Next j, i
    Call msort(arr, temp, 1, UBound(arr, 1) - 1, 19, True) '按辅助列恢复原序
    For i = 1 To UBound(arr, 1) - 1 '按班级中总分正排名
      For j = i To UBound(arr, 1) - 1
        If arr(j, 3) <> arr(j + 1, 3) Then '按班级分段
          Call msort(arr, temp, i, j, 9, False) '班级总分降序
          Call rank(arr, i, j, 9, 18)
          i = j: Exit For
        End If
    Next j, i
    Call msort(arr, temp, 1, UBound(arr, 1) - 1, 19, True) '按辅助列恢复原序
    .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
  End With
End Sub

Function rank(arr, first, last, key, col) '美式排名
  Dim i, j, m
  m = 1: arr(first, col) = 1
  For i = first + 1 To last
    m = m + 1
    arr(i, col) = IIf(arr(i, key) = arr(i - 1, key), arr(i - 1, col), m)
  Next
End Function

Function msort(arr, temp, first, last, key, order)
  Dim i As Long, j As Long, k As Long, kk As Long, mid As Long
  If first <> last Then
    mid = Int((first + last) / 2)
    msort arr, temp, first, mid, key, order
    msort arr, temp, mid + 1, last, key, order
    i = first: j = mid + 1: k = first
    While i <= mid And j <= last
      If arr(i, key) > arr(j, key) Xor order Then
        For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(i, kk): Next
        k = k + 1: i = i + 1
      Else
        For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(j, kk): Next
        k = k + 1: j = j + 1
      End If
    Wend
    While i <= mid
      For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(i, kk): Next
      k = k + 1: i = i + 1
    Wend
    While j <= last
      For kk = 1 To UBound(arr, 2): temp(k, kk) = arr(j, kk): Next
      k = k + 1: j = j + 1
    Wend
    For i = first To last
      For j = 1 To UBound(arr, 2)
        arr(i, j) = temp(i, j)
    Next j, i
  End If
End Function

熊文来

一把小刀闯天下 发表于 2018-11-1 13:31
'类似的这帖子你发过。只写了第一个问题的代码，后面2个问题理解起来太费劲，，，

'假设A、B、C列有序， ...

大侠 我主要是要是解决问题2  三率那张表。有空帮我看看 谢谢

一把小刀闯天下

熊文来 发表于 2018-11-1 14:15
大侠 我主要是要是解决问题2  三率那张表。有空帮我看看 谢谢

你这第二个问题看得我头都大了一圈也没看懂，就算看得懂估计也是一个重体力活。可以简化表格这样才会有人来帮你，，，