求VBA，关于成绩统计的简单问题

qcdf

本来这个统计表，用函数和公式来实现比较简单，但现在年级上需要这个统计表，他们单独组织考试的时候自己弄一下，容易把一些数据搞得乱七八糟，就想着论坛里求大佬用VBA给弄一下，也学习一下。方便年级老师一键统计。

VBA达到的目的和要求：
在【成绩统计】表里，按表头信息所标示的区域，拉取或统计以下数据信息：

1、按照班级顺序从【学生原始成绩】表里拉取考生信息和原始成绩。
2、然后按照【成绩设置】表里的折算规则，统计出折算成绩。
3、根据折算成绩，进行单科成绩的年级排名。
4、在最后的总分及排名区域，计算原始总分和折算总分，并根据原始总分和折算总分进行年级排名和本班班级排名。
     （排名规则与rank函数规则一样，即分数相同，排名相同，不接续）

详见附件：
成绩统计表.zip (199.57 KB, 下载次数: 15)

2024-12-21 15:46 上传

点击文件名下载附件

ykcbf1100

要求还挺多。

chxw68

简单问题就留给初学者吧。

shiruiqiang

新手比较粗浅的写法，后面自己照着写一下
只写一半

翁知江安

Sub chengjitj()
Dim i, j, k, irow, irow1, kk, m, n, p, q, s, ss, t
Dim ar, br, tepar
irow = Sheets("学生原始成绩").[a10000].End(xlUp).Row
ar = Sheets("学生原始成绩").Range("a1:n" & irow)
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
br = Sheets("成绩设置").[a1].Resize(11, 6)
For j = 3 To UBound(br)
  d1(br(j, 1)) = br(j, 3)
Next
For i = 3 To irow
    d2(ar(i, 1)) = ""
Next
Sheets("成绩统计").[a4].Resize(1000, 38).ClearContents
ReDim tepar(1 To irow - 2, 1 To 38)
For Each kk In d2.keys
   For k = 3 To irow
   If kk = ar(k, 1) Then
      n = n + 1
     For m = 1 To 14
      tepar(n, m) = ar(k, m)
       Next
      For p = 15 To 23
      tepar(n, p) = tepar(n, p - 9) * d1(ar(2, p - 9))
      Next
    End If
  Next
  
  With Sheets("成绩统计")
  irow1 = .[a10000].End(xlUp).Row
  .Cells(irow1 + 1, 1).Resize(n, 38) = tepar
  For s = irow1 + 1 To irow1 + n
        .Cells(s, 33) = WorksheetFunction.Sum(.Cells(s, 7).Resize(1, 8))
        .Cells(s, 36) = WorksheetFunction.Sum(.Cells(s, 15).Resize(1, 8))
   Next
   For ss = irow1 + 1 To irow1 + n
      .Cells(ss, 34) = WorksheetFunction.Rank(.Cells(ss, 33), .Cells(irow1 + 1, 33).Resize(n, 1))
      .Cells(ss, 37) = WorksheetFunction.Rank(.Cells(ss, 36), .Cells(irow1 + 1, 36).Resize(n, 1))
    Next
    End With
    n = 0
Next
With Sheets("成绩统计")
irow1 = .[a10000].End(xlUp).Row
For q = 4 To irow1
   .Cells(q, 35) = WorksheetFunction.Rank(.Cells(q, 33), .Cells(4, 33).Resize(irow1 - 3, 1))
   .Cells(q, 38) = WorksheetFunction.Rank(.Cells(q, 36), .Cells(4, 36).Resize(irow1 - 3, 1))
   For t = 24 To 32
        .Cells(q, t) = WorksheetFunction.Rank(.Cells(q, t - 9), .Cells(4, t - 9).Resize(irow1 - 3, 1))
     Next
Next
End With
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

qcdf

翁知江安 发表于 2024-12-21 20:47
供参考，欢迎批评指正

非常感谢，学习了。我在认真看。

qcdf

shiruiqiang 发表于 2024-12-21 19:15
新手比较粗浅的写法，后面自己照着写一下
只写一半

非常感谢老师，我也在学习。

qcdf

chxw68 发表于 2024-12-21 18:59
简单问题就留给初学者吧。

VBA还是复杂，特别是我这种小白。

qcdf

ykcbf1100 发表于 2024-12-21 18:30
要求还挺多。

我写的有点啰嗦了