求能计算16个文件里的总人数、平均分、及格率的VBA代码

小草看日出

chxw68 发表于 2021-12-10 17:48
修改好了。

感谢侠圣，帮我解决了难题。这两天通过验证，计算结果正确，对于最后一名并列的问题，进行了完美的解决。但偶然发现，对于总人数和90%人数，虽然结果正确，但都是以第一列为基准得出的，比如源成绩文件里第1列里面如果少了一个学校名称，即使第6列成绩里有，但总人数仍少一个；如果源成绩文件里第1列学校名长里面没少，但第6列成绩里少一个，但总人数仍是原来的没变。相比之下，之前取全部人数求三率那个里面的代码的总人数是以第6列分数为基准得出的，感觉更实用，那样，有分数了就算作一个人，如果缺考没分数了就当作没有人。这两天，我尝试几次也改成这样的，可是总是不成功，所以没及时回复，请见谅。能不能改成象之前那个代码里的总人数和90%人数都以源成绩文件第6列分数为基准得出的？再次感谢。

chxw68

小草看日出 发表于 2021-12-13 10:53
感谢侠圣，帮我解决了难题。这两天通过验证，计算结果正确，对于最后一名并列的问题，进行了完美的解决。 ...

给你写了代码后就石沉大海了！你自己研究吧！

小草看日出

chxw68 发表于 2021-12-13 11:28
给你写了代码后就石沉大海了！你自己研究吧！

让您生气了，对不起。这两天被我们当地人事部门抽调去外地当评委了，白天需要从早到晚干一天活儿，只有晚上回到住处才能验证，另外想着经过多次验证后再把准确情况反馈给您，所以回复晚了，望大神海函。感谢您的帮助。

小草看日出

chxw68 发表于 2021-12-13 11:28
给你写了代码后就石沉大海了！你自己研究吧！

期待禇老师帮忙修改。这个有意义，比如有时有缺考的，或者0分的，为了公平，我们有时不把缺考的或0分的算作总人数，所以，如果以分数为基准确定总人数和90%人数，就能便于随时调整。谢谢您。

jwjnh001

Sub test1()
  Dim r%, i%
  Dim arr, brr(1 To 1000, 1 To 9)
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim Mypath$, Myname$
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Mypath = ThisWorkbook.Path & "\16科期考成绩\"
  Myname = Dir(Mypath & "*.xlsx")
  
  m = 0
  Do While Myname <> ""
    If Myname <> ThisWorkbook.Name Then
      xm = Left(Myname, 2)
      m = m + 1
      brr(m, 1) = xm  '将文件名前两个字装入数组，比如一数
      Set wb = GetObject(Mypath & Myname) '在不打开文件的状态下读取文件
      With wb
        With .Worksheets(1)
          r = .Cells(.Rows.Count, 1).End(xlUp).Row  '总行数
          If r > 1 Then  '如果表不为空
            arr = .Range("a2:f" & r) '将各表中的数据分别装入数组arr
            brr(m, 3) = Round(UBound(arr) * 0.9, 0) '汇总表第三列为各表90%的人数，保留整数
            '比如第一张表是一数，ubound(arr)是852，不含标题行
            fs = Application.Large(Application.Index(arr, 0, 6), brr(m, 3))
            '分别求出各单位表中第6列中前90%的成绩，index交叉引用数组中第1行第6列的数据，在数组中第一个元素的位置是0
            '计算出第90%人数为名次的成绩，比如一数这张表共852人，90%是767名，第767名是86分，赋给变量fs
            rs = 0
            For i = 1 To UBound(arr)
              brr(m, 2) = brr(m, 2) + 1
              If arr(i, 6) >= fs Then  ' 当成绩大于或等于第90%人数为名次的成绩时，比如一数为86分
                rs = rs + 1  '对大于fs分数的人数进行累加计数
                brr(m, 4) = brr(m, 4) + arr(i, 6) '对大于等于fs的成绩进行累加，如果小于则跳过不累加
                If arr(i, 6) >= 59.5 Then
                  brr(m, 5) = brr(m, 5) + 1  '对大于等于fs分数的及格人数进行计数累加，放第5列
                End If
                If arr(i, 6) >= 79.5 Then
                  brr(m, 7) = brr(m, 7) + 1  '对大于等于fs分数的优秀人数进行计数累加，放第7列
                End If
              End If
            Next
            If rs > brr(m, 3) Then '当符合条件的人数大于前90%成绩的人数时，比如一数大于86分的有769人，原因是有重分的学生
              brr(m, 4) = brr(m, 4) - (rs - brr(m, 3)) * fs '因只截取前90%人数，将多余的人数的成绩从总成绩减下来
              If fs >= 59.5 Then
                brr(m, 5) = brr(m, 5) - (rs - brr(m, 3)) '因只截取前90%人数，将多余的及格人数从总及格人数减下来
              End If
              If fs >= 79.5 Then
                brr(m, 7) = brr(m, 7) - (rs - brr(m, 3)) '因只截取前90%人数，将多余的优秀人数从总优秀人数减下来
              End If
            End If
          End If
        End With
        .Close False
      End With
    End If
    Myname = Dir  '处理下一张工作簿
  Loop
  If m = 0 Then
    MsgBox "没有符合条件数据！"
    Exit Sub
  End If
  
  For i = 1 To m  '指要统计的文件个数，共16个，所以m最后等于16 或者说按A列循环
    brr(i, 9) = InStr("一二三四五六", Left(brr(i, 1), 1)) * 10 + InStr("语数英", Right(brr(i, 1), 1))
    '是从起始位置开始向后找到被搜索的字符串第一次出现的位置，如果找的到就返回其在原字符串中的位置，否则就返回0。
    'InStr("一二三四五六", Left(brr(i, 1), 1)) * 10    brr(i,1) 为一数，则一的起始位置为1
    '一数为12，一语为11，一英为13，二数为22，二语为21，二英为23，为了按一二三和语数英排序
    If Len(brr(i, 3)) <> 0 And brr(i, 3) <> 0 Then
      brr(i, 4) = Round(brr(i, 4) / brr(i, 3), 2)  '计算平均成绩，放在第4列
      brr(i, 6) = Round(brr(i, 5) / brr(i, 3), 4) * 100  '计算合格率
      brr(i, 8) = Round(brr(i, 7) / brr(i, 3), 4) * 100  '计算优秀率
    End If
  Next

  With Worksheets("三率统计表")
    .UsedRange.Offset(2, 0).Clear '将统计表内容进行删除
    .Range("e:e,g:g").NumberFormatLocal = "0.00"  '将E列和G列转化成数值格式
    .Range("a3").Resize(m, UBound(brr, 2)) = brr  'Ubound(brr,2)=9，共16行9列
    .Range("a3").Resize(m, UBound(brr, 2)).Sort key1:=.Range("i3"), order1:=xlAscending, Header:=xlNo
    'i列是辅助列，按i列为关键字进行升序排序
    .Columns(9).Clear  '清除i列辅助列 辅助列就是由brr(i,9)构造的列，为了上面的排序
   
    With .Range("a1")  '设置标题
      With .Font
        .Name = "微软雅黑"
        .Size = 18
      End With
    End With
   
    With .Range("a2").Resize(1 + m, 8)
      .Borders.LineStyle = xlContinuous  '设置内容的边框
      With .Font
        .Name = "微软雅黑"
        .Size = 11
      End With
    End With
    .Rows(1).RowHeight = 30   '标题行行高30
    .Rows(2).Resize(1 + m).RowHeight = 20  '内容行行高20
   
    With .UsedRange
      .HorizontalAlignment = xlCenter  '水平居中
      .VerticalAlignment = xlCenter     '垂直居中对齐
    End With
  End With
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True

End Sub

jwjnh001

Sub test1()
  Dim r%, i%
  Dim arr, brr(1 To 1000, 1 To 9)
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim Mypath$, Myname$
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Mypath = ThisWorkbook.Path & "\16科期考成绩\"
  Myname = Dir(Mypath & "*.xlsx")
  
  m = 0
  Do While Myname <> ""
    If Myname <> ThisWorkbook.Name Then
      xm = Left(Myname, 2)
      m = m + 1
      brr(m, 1) = xm  '将文件名前两个字装入数组，比如一数
      Set wb = GetObject(Mypath & Myname) '在不打开文件的状态下读取文件
      With wb
        With .Worksheets(1)
          r = .Cells(.Rows.Count, 1).End(xlUp).Row  '总行数
          If r > 1 Then  '如果表不为空
            arr = .Range("a2:f" & r) '将各表中的数据分别装入数组arr
            brr(m, 3) = Round(UBound(arr) * 0.9, 0) '汇总表第三列为各表90%的人数，保留整数
            '比如第一张表是一数，ubound(arr)是852，不含标题行
            fs = Application.Large(Application.Index(arr, 0, 6), brr(m, 3))
            '分别求出各单位表中第6列中前90%的成绩，index交叉引用数组中第1行第6列的数据，在数组中第一个元素的位置是0
            '计算出第90%人数为名次的成绩，比如一数这张表共852人，90%是767名，第767名是86分，赋给变量fs
            rs = 0
            For i = 1 To UBound(arr)
              brr(m, 2) = brr(m, 2) + 1
              If arr(i, 6) >= fs Then  ' 当成绩大于或等于第90%人数为名次的成绩时，比如一数为86分
                rs = rs + 1  '对大于fs分数的人数进行累加计数
                brr(m, 4) = brr(m, 4) + arr(i, 6) '对大于等于fs的成绩进行累加，如果小于则跳过不累加
                If arr(i, 6) >= 59.5 Then
                  brr(m, 5) = brr(m, 5) + 1  '对大于等于fs分数的及格人数进行计数累加，放第5列
                End If
                If arr(i, 6) >= 79.5 Then
                  brr(m, 7) = brr(m, 7) + 1  '对大于等于fs分数的优秀人数进行计数累加，放第7列
                End If
              End If
            Next
            If rs > brr(m, 3) Then '当符合条件的人数大于前90%成绩的人数时，比如一数大于86分的有769人，原因是有重分的学生
              brr(m, 4) = brr(m, 4) - (rs - brr(m, 3)) * fs '因只截取前90%人数，将多余的人数的成绩从总成绩减下来
              If fs >= 59.5 Then
                brr(m, 5) = brr(m, 5) - (rs - brr(m, 3)) '因只截取前90%人数，将多余的及格人数从总及格人数减下来
              End If
              If fs >= 79.5 Then
                brr(m, 7) = brr(m, 7) - (rs - brr(m, 3)) '因只截取前90%人数，将多余的优秀人数从总优秀人数减下来
              End If
            End If
          End If
        End With
        .Close False
      End With
    End If
    Myname = Dir  '处理下一张工作簿
  Loop
  If m = 0 Then
    MsgBox "没有符合条件数据！"
    Exit Sub
  End If
  
  For i = 1 To m  '指要统计的文件个数，共16个，所以m最后等于16 或者说按A列循环
    brr(i, 9) = InStr("一二三四五六", Left(brr(i, 1), 1)) * 10 + InStr("语数英", Right(brr(i, 1), 1))
    '是从起始位置开始向后找到被搜索的字符串第一次出现的位置，如果找的到就返回其在原字符串中的位置，否则就返回0。
    'InStr("一二三四五六", Left(brr(i, 1), 1)) * 10    brr(i,1) 为一数，则一的起始位置为1
    '一数为12，一语为11，一英为13，二数为22，二语为21，二英为23，为了按一二三和语数英排序
    If Len(brr(i, 3)) <> 0 And brr(i, 3) <> 0 Then
      brr(i, 4) = Round(brr(i, 4) / brr(i, 3), 2)  '计算平均成绩，放在第4列
      brr(i, 6) = Round(brr(i, 5) / brr(i, 3), 4) * 100  '计算合格率
      brr(i, 8) = Round(brr(i, 7) / brr(i, 3), 4) * 100  '计算优秀率
    End If
  Next

  With Worksheets("三率统计表")
    .UsedRange.Offset(2, 0).Clear '将统计表内容进行删除
    .Range("e:e,g:g").NumberFormatLocal = "0.00"  '将E列和G列转化成数值格式
    .Range("a3").Resize(m, UBound(brr, 2)) = brr  'Ubound(brr,2)=9，共16行9列
    .Range("a3").Resize(m, UBound(brr, 2)).Sort key1:=.Range("i3"), order1:=xlAscending, Header:=xlNo
    'i列是辅助列，按i列为关键字进行升序排序
    .Columns(9).Clear  '清除i列辅助列 辅助列就是由brr(i,9)构造的列，为了上面的排序
   
    With .Range("a1")  '设置标题
      With .Font
        .Name = "微软雅黑"
        .Size = 18
      End With
    End With
   
    With .Range("a2").Resize(1 + m, 8)
      .Borders.LineStyle = xlContinuous  '设置内容的边框
      With .Font
        .Name = "微软雅黑"
        .Size = 11
      End With
    End With
    .Rows(1).RowHeight = 30   '标题行行高30
    .Rows(2).Resize(1 + m).RowHeight = 20  '内容行行高20
   
    With .UsedRange
      .HorizontalAlignment = xlCenter  '水平居中
      .VerticalAlignment = xlCenter     '垂直居中对齐
    End With
  End With
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True

End Sub

jwjnh001

这是对chxw68写的代码的解释，不知道对不对，有错请指正。

小草看日出

jwjnh001 发表于 2021-12-13 19:54
Sub test1()
  Dim r%, i%
  Dim arr, brr(1 To 1000, 1 To 9)

感谢注释，非常详细，非常适宜学习，辛苦您啦，多谢。

小草看日出

jwjnh001 发表于 2021-12-13 19:54
Sub test1()
  Dim r%, i%
  Dim arr, brr(1 To 1000, 1 To 9)

多谢，今天我没有积分了，明天一定记着评分。

小草看日出

jwjnh001 发表于 2021-12-13 21:00
这是对chxw68写的代码的解释，不知道对不对，有错请指正。

感谢，真的很感动，因为您的注释需要花很长时间，感谢您的无私帮助。