请教大师用VBA对成绩进行分班分科统计

不想困在原地

请教大师用VBA对成绩进行分班分科统计

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, m, p
  arr = Sheets("成绩").[a1].CurrentRegion.Offset(1)
  ReDim brr(1 To UBound(arr, 1), 1 To 15)
  Call qsort(arr, 2, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  p = 2
  For i = 2 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call qsort(arr, p, i, 2, UBound(arr, 2), 2)
      For j = p To i
        If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
          For k = 4 To UBound(arr, 2)
            m = m + 1: brr(m, 6) = 1000
            brr(m, 1) = arr(i, 1): brr(m, 2) = arr(j, 2): brr(m, 3) = arr(1, k): brr(m, 4) = j - p + 1
            For kk = p To j
              If brr(m, 5) < arr(kk, k) Then brr(m, 5) = arr(kk, k)
              If brr(m, 6) > arr(kk, k) Then brr(m, 6) = arr(kk, k)
              If arr(kk, k) >= 85 Then
                brr(m, 7) = brr(m, 7) + 1
                brr(m, 11) = brr(m, 11) + 1
              ElseIf arr(kk, k) >= 75 Then
                brr(m, 9) = brr(m, 9) + 1
                brr(m, 11) = brr(m, 11) + 1
              ElseIf arr(kk, k) >= 60 Then
                brr(m, 11) = brr(m, 11) + 1
              Else
                brr(m, 13) = brr(m, 13) + 1
              End If
              brr(m, 15) = brr(m, 15) + arr(kk, k)
            Next
            For kk = 8 To 14 Step 2
              brr(m, kk) = Round(brr(m, kk - 1) / brr(m, 4), 4)
            Next
            brr(m, 15) = Round(brr(m, 15) / brr(m, 4), 2)
          Next
          p = j + 1
        End If
      Next
      p = i + 1
    End If
  Next
  arr = Array(8, 10, 12, 14)
  With Sheets("分析")
    .[a3].Resize(Rows.Count - 2, UBound(brr, 2)).Clear
    For i = 0 To UBound(arr)
      .Cells(3, arr(i)).Resize(m).NumberFormatLocal = "0.00%"
    Next
    With [a3].Resize(m, UBound(brr, 2))
      .Value = brr
      .Borders.LineStyle = xlContinuous
    End With
  End With
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) / 2, key)
  While i <= j
    While arr(i, key) < x: i = i + 1: Wend
    While x < arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

不想困在原地

一把小刀闯天下 发表于 2019-12-6 18:49
Option Explicit

Sub test()

高手，。及格人数应该是>=60的总人数,成绩能用两位小数字表示，率用百分数表示那就完美了。

不想困在原地

及格人数不对,应该大于或等于60的总人数,

一把小刀闯天下

不想困在原地 发表于 2019-12-9 10:32
及格人数不对,应该大于或等于60的总人数,

2楼及格率已修改，原来是按档次来计算人数的。另外增加了输出表格格式设置，，，

不想困在原地

太感谢了!解决了我这个问题.