一分两率计算各班各学科平均分、合格率、优秀率

zhuql2921

对，只能先用公式提取前面几张表，最后用VBA生成教师个人分析表

chxw68

zhuql2921 发表于 2021-11-21 15:00
对，只能先用公式提取前面几张表，最后用VBA生成教师个人分析表

新贴子里已经有老师开始解答了。复杂问题适宜由易到难、逐步解决的办法。给你建议过了，抛弃以前所有的代码和公式，从头做起，提供最原始的数据，然后一步一步提出你的需求，VBA代码根据总表就能计算出后面各种统计表，各班成绩表是否必须？另一个教师任课表必须提供，学生符号从哪里获得？

zhuql2921

可能还是和老师讲的样，条件太多了，没有通用的VBA，如果每次写代码就繁了

chxw68

zhuql2921 发表于 2021-11-21 16:14
可能还是和老师讲的样，条件太多了，没有通用的VBA，如果每次写代码就繁了

你讲的通用性准确地来说应该是适应性，如果原始数据表格和结果表格设计得科学合理，代码的适应性还是有保障的。

jacking03

求助大神，如何实现班级一率两分的汇总呢？

jacking03

Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  Set dcs = CreateObject("scripting.dictionary")
  With Worksheets("基本参数")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Range("a1").Resize(r, c)
    For j = 2 To UBound(arr, 2)
      Set dcs(arr(1, j)) = CreateObject("scripting.dictionary")
      For i = 2 To UBound(arr)
        dcs(arr(1, j))(arr(i, 1)) = arr(i, j)
      Next
    Next
  End With
  
  With Worksheets("原始成绩")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    arr = .Range("a2").Resize(r - 1, c)
    For j = 4 To UBound(arr, 2) - 1
      If Not dcs.exists(arr(1, j)) Then
        MsgBox "请在[基本参数]表中设置[" & arr(1, j) & "]有关参数!"
        Exit Sub
      End If
    Next
    For j = 4 To UBound(arr, 2) - 1
      Set d(arr(1, j)) = CreateObject("scripting.dictionary")
      For i = 2 To UBound(arr)
        If Not d(arr(1, j)).exists(arr(i, 1)) Then
          ReDim brr(1 To 9)
          brr(1) = arr(i, 1)
        Else
          brr = d(arr(1, j))(arr(i, 1))
        End If
        brr(2) = brr(2) + 1
        brr(3) = brr(3) + arr(i, j)
        If arr(i, j) >= dcs(arr(1, j))("合格") Then
          brr(5) = brr(5) + 1
        End If
        If arr(i, j) >= dcs(arr(1, j))("优秀") Then
          brr(7) = brr(7) + 1
        End If
        d(arr(1, j))(arr(i, 1)) = brr
      Next
    Next
  End With
  With Worksheets("一分两率")
    .Cells.Clear
    For Each aa In d.keys
      d1.RemoveAll
      arr = Application.Transpose(Application.Transpose(d(aa).items))
      ReDim brr(1 To UBound(arr, 2))
      brr(1) = "合计"
      For i = 1 To UBound(arr)
        For Each x In Array(2, 3, 5, 7)
          brr(x) = brr(x) + arr(i, x)
        Next
        If arr(i, 2) <> 0 Then
          arr(i, 4) = Round(arr(i, 3) / arr(i, 2), 2)
          arr(i, 6) = Round(arr(i, 5) / arr(i, 2), 4) * 100
          arr(i, 8) = Round(arr(i, 7) / arr(i, 2), 4) * 100
        End If
        d1(arr(i, 4)) = d1(arr(i, 4)) + 1
      Next
      If brr(2) <> 0 Then
        brr(4) = Round(brr(3) / brr(2), 2)
        brr(6) = Round(brr(5) / brr(2), 4) * 100
        brr(8) = Round(brr(7) / brr(2), 4) * 100
      End If
      
      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(arr)
        arr(i, 9) = d1(arr(i, 4))
      Next
      r = .Cells(.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then
        r = r + 4
      End If
      With .Cells(r, 1)
        .Value = "初一级（" & aa & "）"
        .Resize(1, 9).Merge
        With .Font
          .Name = "宋体"
          .Size = 18
          .Bold = True
        End With
      End With
      .Cells(r + 1, 1).Resize(1, 9) = Array("班级", "人数", "总分", "平均分", "合格人数", "合格率", "优秀人数", "优秀率", "排名")
      .Cells(r + 2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
      .Cells(r + 2 + UBound(arr), 1).Resize(1, UBound(brr)) = brr
      r1 = .Cells(.Rows.Count, 1).End(xlUp).Row
      With .Range(.Cells(r + 1, 1), .Cells(r1, 9))
        .Borders.LineStyle = xlContinuous
      End With
    Next
    With .UsedRange
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
    End With
  End With
End Sub

jacking03

jacking03 发表于 2022-11-28 12:11
求助大神，如何实现班级一率两分的汇总呢？

已经在论坛中找到褚老师写的代码，稍微修改一下可以用，把教师的一分两率也整合了一下。请大神再帮忙把班级一分两率的任课老师完善下，谢谢！

chxw68

修改好了。

jacking03

chxw68 发表于 2022-11-28 15:36
修改好了。

非常完美，谢谢褚老师！

jacking03

如果分数栏为空，就不统计，只计算实考人数就好，要怎么修改