ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的测验 > Excel VBA > 【罗刚君VBA免费课作业题】之第23课作业之三

【罗刚君VBA免费课作业题】之第23课作业之三

作者：绿色风 分类： 时间：2022-08-18 浏览：202
楼主
罗刚君		 提示：此题目是“VBA入门免费教学群”（群号:30729794）的课后作业
请未参与听课者绕道，谢谢配合。

_____________________________________________________


 


第23课作业题三.rar


说明：
请用附件中的数据，通过VBA代码得到上图中的结果-----提取至少三科不及格者的信息。

_____________________________________________________
请提交作业时 直接贴代码就行了
不要上附件，操作起来方便一些
比较忙
多谢配合
_____________________________________________________
答案

第23课作业题三.rar
2楼
静思雨
  1. Sub test()
  2.     Dim iRow As Integer, iColumn As Integer
  3.     Dim iLastrow As Integer, iLastcolumn As Integer
  4.     Dim iCount As Integer
  5.     Dim tempStr As String
  6.     Dim result As String
  7.     Dim rng As Range
  8.     Set rng = Cells.SpecialCells(xlCellTypeLastCell)
  9.     iLastrow = rng.Row
  10.     iLastcolumn = rng.Column
  11.     For iRow = 2 To iLastrow
  12.      For iColumn = 2 To iLastcolumn
  13.         If Cells(iRow, iColumn).Value < 60 Then
  14.           iCount = iCount + 1
  15.           tempStr = tempStr & Cells(1, iColumn) & Cells(iRow, iColumn) & _
  16.           String(15 - LenB(Cells(1, iColumn) & Cells(iRow, iColumn)), " ")
  17.         End If
  18.      Next
  19.      If iCount >= 3 Then
  20.         result = result & vbCrLf & Cells(iRow, 1) & ":" & String(6 - LenB(Cells(iRow, 1)), " ") & tempStr
  21.      End If
  22.      iCount = 0
  23.      tempStr = ""
  24.     Next
  25.     MsgBox "至少三科不及格者：" & result, vbInformation, "查找结果"
  26. End Sub
3楼
NULL		 Option Explicit

Sub 查询至少三科不及格()
Dim Arr, Temp As String, Str As String, i As Long, j As Long, Cnt As Byte
Arr = Range("a1").CurrentRegion '获取源数据
For i = 2 To UBound(Arr, 1) '遍历每个学生
    Temp = Arr(i, 1) & ":" '姓名
    Cnt = 0 '记录不及格的科目数
    For j = 2 To UBound(Arr, 2) '成绩中遍历
        If Arr(i, j) < 60 Then
            Temp = Temp & Arr(1, j) & Arr(i, j) & vbTab '成绩分数
            Cnt = Cnt + 1
        End If
    Next
    If Cnt >= 3 Then
        Str = Str & Temp & Chr(10) '符合条件的写入Str
    End If
Next
If Str = "" Then Str = "无" 'str为空,查询结果不存在,显示无
MsgBox "至少三科不及格者" & Chr(10) & Str, vbInformation, "查询结果"
End Sub
4楼
NULL		 Option Explicit

Sub 查询至少三科不及格()
Dim Arr, Temp As String, Str As String, i As Long, j As Long, Cnt As Byte
Arr = Range("a1").CurrentRegion '获取源数据
For i = 2 To UBound(Arr, 1) '遍历每个学生
    Temp = Arr(i, 1) & ":" '姓名
    Cnt = 0 '记录不及格的科目数
    For j = 2 To UBound(Arr, 2) '成绩中遍历
        If Arr(i, j) < 60 Then
            Temp = Temp & Arr(1, j) & Arr(i, j) & vbTab '成绩分数
            Cnt = Cnt + 1
        End If
    Next
    If Cnt >= 3 Then
        Str = Str & Temp & Chr(10) '符合条件的写入Str
    End If
Next
If Str = "" Then Str = "无" 'str为空,查询结果不存在,显示无
MsgBox "至少三科不及格者" & Chr(10) & Str, vbInformation, "查询结果"
End Sub
5楼
浮华缠绕指尖		 super
  1. Sub 作业()
  2. Dim arr, i, m
  3. Dim d, k, t
  4. Application.ScreenUpdating = False
  5. arr = [a1].CurrentRegion
  6. Set d = CreateObject("scripting.dictionary")
  7. '采用字典算法
  8. For i = 2 To UBound(arr)    '对行进行循环'
  9.     m = 0   '次数清0后进行下一行'
  10.     For j = 2 To UBound(arr, 2) '对列进行循环'
  11.         If IsNumeric(arr(i, j)) And arr(i, j) < 60 Then '对条件进行判断'
  12.             m = m + 1   ''对满足条件的进行次数累加
  13.             d(arr(i, 1)) = d(arr(i, 1)) & arr(1, j) & arr(i, j) & vbTab '取字典的关键字与相应的item,对应为一行所有满足条件的值'
  14.         End If
  15.     Next
  16.     If m < 3 Then d.Remove (arr(i, 1))  '如果次数小于3,将它从字典中排除'
  17.       
  18. Next
  19. '后面为对字典进行赋值和输出'
  20. k = d.keys: t = d.items
  21. For i = 0 To d.Count - 1
  22.     s = s & k(i) & vbTab & t(i) & Chr(10)
  23. Next
  24. MsgBox s
  25. Set d = Nothing
  26. Application.ScreenUpdating = True
  27. End Sub
6楼
ynzsvt		 Sub 找当前工作表不及格超过三次的人()
Dim r%, c%, Re%, Ce%, Str$, FindCount%, Rng As Range '定义变量
Set Rng = ActiveSheet.UsedRange '表区域
Re = Rng.Rows.Count '总行数
Ce = Rng.Columns.Count '总列数
Str = "至少三科不及格者：" & vbCrLf & vbCrLf '输出信息的头部
With Rng '表区域进行统计
  For r = 2 To Re '逐个人进行统计
   If Application.WorksheetFunction.CountIf(.Rows(r), "<60") >= 3 Then '对不及格科目数量符合的进行处理
    FindCount = FindCount + 1 '统计人数
    Str = Str & .Cells(r, 1) & ":" & vbTab '人名
    For c = 2 To Ce '逐个科目查看成绩
     If .Cells(r, c) < 60 Then Str = Str & .Cells(1, c) & .Cells(r, c) & vbTab '科目和成绩
    Next c
    Str = Str & vbCrLf '人与人之间换行
   End If
  Next r
End With
Set Rng = Nothing
Str = Str & vbCrLf & "共找到" & FindCount & "位符合条件的人" '计数输出
If FindCount > 1 Then MsgBox Str, vbInformation, "查找结果" Else MsgBox "未找到符合条件的", vbCritical, "查找结果" '条件输出
End Sub
7楼
无言的人		 无言的人
增加一个人数提示

  2. Sub ScoreFail()
  3.     Dim UsedArr, SfArr, UsdeRow As Integer, UsdeCol As Byte
  4.     Dim iRow As Integer, iCol As Integer, SfCou As Integer, Cous As Integer
  5.     Dim SF_Str As String, Sfc_Str As String, SF_Arr
  6.     Dim SfMan As Byte, SavRng As Range
  7.     Rem 如何工作表为使用过即推出
  8.     If IsEmpty(Sheet1.UsedRange) Then End
  9.     Rem UsedArr 为Sheet1区域的单元格数值的数组
  10.     UsedArr = Application.Intersect(Sheet1.UsedRange, Sheet1.Range("A1").CurrentRegion).Value
  11.     Rem UsdeRow 和  UsdeCol 分别 UsedArr数组中的第1 和 第2 维的上标
  12.     UsdeRow = UBound(UsedArr): UsdeCol = UBound(UsedArr, 2)
  13.     Rem 提示输入需要统计几科目不及格的数字
  14.         Rem SfMan 小于1 大于 第二维最大上标 或 不为数字时，重复提示输入正确数字
  15.     Do While SfMan < 1 Or SfMan > UsdeCol Or Not IsNumeric(SfMan)
  16.         SfMan = Application.InputBox("请输入最少及个科目不及格的数字" & vbCr _
  17.         & "例如输入数字3，为查询至少3科及以上不及格的科目", "不及格科目个数", 3, , , , , 1)
  18.     Loop
  19.     Rem SF_Str "至少 XX 科不及格者：" ，作用为记录所以满足要求的文本类型变量
  20.     SF_Str = "至少" & SfMan & "科不及格者："
  21.     Rem Cous 所有不满足的计数器
  22.     Cous = 0
  23.     Rem 循环获取 XX科以上不及格的过程，以姓名行开始，再逐列获取小于60分的对应科目及成绩
  24.     For iRow = 2 To UsdeRow     '按姓名循环
  25.         For iCol = 2 To UsdeCol ' 按科目循环
  26.             If UsedArr(iRow, iCol) < 60 Then        '当分数小于60是写入各人临时文本变量Sfc_Str中
  27.                SfCou = SfCou + 1    '个人不合格科目计数器
  28.                Rem 将 科目及成绩写入变量中
  29.                Sfc_Str = Sfc_Str & UsedArr(1, iCol) & " " & UsedArr(iRow, iCol) & vbTab
  30.             End If
  31.         Next iCol
  32.         Rem 以个人科目不合数判断写入SF_Str 变量中
  33.         If SfCou < SfMan Then       '各人科目不满足数是否大于统计科目要求
  34.            Rem 是清空 Sfc_Str里的文本内容
  35.            Sfc_Str = "" ': SF_Str = SF_Str & Sfc_Str
  36.         Else
  37.            Rem 大于等于统计科目数时，将Sfc_Str内容 与 SF_Str的内容合并，并清空 Sfc_Str
  38.            Rem Cous计数器满足时每次都+1
  39.            Sfc_Str = UsedArr(iRow, 1) & "：" & Sfc_Str
  40.            SF_Str = SF_Str & vbCr & Sfc_Str
  41.            Sfc_Str = ""
  42.            Cous = Cous + 1
  43.         End If
  44.         Rem 清空各人各科的不满足科目计数器
  45.         SfCou = 0
  46.     Next iRow
  47.     Rem 当Cous计数器大于0
  48.     If Cous > 0 Then
  49.         Rem 当>0时 显示所有满足的人员及科目、成绩
  50.         [color=Red]SF_Str = "共有" & Cous & "人" & SF_Str
  51.         MsgBox SF_Str[/color]
  52.         Rem 将提示转换为数组
  53.         SF_Arr = Split(SF_Str, vbCr)
  54.         Rem 新建一个保存不及格科目的工作表位置
  55.         Set SavRng = Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1")
  56.         Rem 将SF_Arr数组写入新建工作表的A1单元格
  57.         SavRng.Resize(UBound(SF_Arr) + 1) = WorksheetFunction.Transpose(SF_Arr)
  58.     Else
  59.         Rem 小于0 则提示不存在不满足的科目数的提示
  60.         MsgBox "本成绩表中不存在" & SfMan & "科及以上不及格的人员"
  61.     End If
  62. End Sub
8楼
liaozhifa33		 占楼。。
9楼
wangxf9209		 江苏-雪峰
  1. Sub 查询不及格()
  2.     Dim RNG As Range, irow As Integer, icol As Integer, i As Integer, j As Integer, k As Integer, n As Integer, m, s1, s2, s3
  3.     Application.ScreenUpdating = False          '关闭屏幕更新
  4.     irow = Worksheets("SHEET1").Cells(Rows.Count, 1).End(3).Row   '取得数据区域的最大行数
  5.     icol = Worksheets("SHEET1").Cells(1, Columns.Count).End(1).Column   '取数据区域的最大列数
  6. 重新查询:        '插入行标签
  7.     m = InputBox("请输入要查找几科不及格的" & vbCrLf & "请输入大于0的整数")  '弹出输入框提示用户输入要查询至少几科不及格的
  8.     If StrPtr(m) = 0 Then  '判断用户是否点击了“取消”按钮或直接退出了
  9.         k = MsgBox("您真的放弃此次查询？" & vbCrLf & "点""确定""退出，点""取消""重新开始查询。", 1 + 32)  '返回用户点击哪个按钮
  10.         If k = 1 Then   '如果用户点击了“确定”按钮，就直接退出过程
  11.             End
  12.         Else
  13.             GoTo 重新查询       '如果用户点击的是“取消”按钮，就跳转到设置的行标签处继续运行
  14.         End If
  15.     ElseIf Not IsNumeric(m) Or m = 0 Then           '判断用户如果输入了文本字符或0，就弹出提示，并跳转到行标签处继续运行
  16.         MsgBox "请重新输入大于0的整数", 48
  17.         GoTo 重新查询
  18.     End If
  19.     For Each RNG In Range("B2", Cells(irow, icol))  '循环
  20.         i = i + 1                                     '设置计数器，用以记录循环了每个人的科目数
  21.         If RNG < 60 Then
  22.             j = j + 1    '每查找到一个不及格的，计数器就加1
  23.             s1 = Cells(1, RNG.Column) & IIf(RNG = "", "缺考", RNG)  '将循环到不及格的分数与科目合并为字符串，如果分数为空就用“缺考”代替。
  24.             s2 = s2 & s1 & Space(12 - LenB(StrConv(s1, 128)))   '为了使显示的记录对齐，根据科目及数字的字符来插入相应的空格调整位置
  25.         End If
  26.         If i = icol - 1 Then    '当遍历完一个人的所有分数后，就（下一行）判断其有几个不及格
  27.             If j >= m Then     '如果不及格数达到指定的科目数后，就将该同学的姓名及不及格记录合并为字符串
  28.                 s3 = s3 & vbCrLf & Cells(RNG.Row, 1) & IIf(Len(Cells(RNG.Row, 1)) = 2, "  :", ":") & s2     '同样添加了调节位置的语句（函数）
  29.               n = n + 1    '计数器，用以记录有多少条符合条件的记录
  30.             End If
  31.             i = 0: j = 0: s2 = ""   '计数器归零，字符串清空
  32.         End If
  33.     Next
  34.     MsgBox IIf(s3 = "", "没有查到符合条件的记录！", Application.Text(m, "至少[DBNum1]0科不及格者：") & s3 & vbCrLf & vbCrLf & "共查询到" & n & "条记录"), 64, "查找结果"  '显示最终查询结果
  35.     Application.ScreenUpdating = True    '开启屏幕更新
  36. End Sub
10楼
wendel		 无心手语
  1. Sub NotPass()
  2.     Dim MaxRow As Integer, MaxColumn As Integer
  3.     Dim R As Integer, C As Integer, NGCount As Integer
  4.     Dim Result As String, TempStr As String
  5.     Application.ScreenUpdating = False
  6.     MaxRow = Cells(Rows.Count, 1).End(xlUp).Row '获取数据源区域最大行
  7.     MaxColumn = Cells(1, Columns.Count).End(xlToLeft).Column '获取数据源区域最大列
  8.     For R = 2 To MaxRow '成绩行循环
  9.         For C = 2 To MaxColumn '成绩列循环
  10.             If Cells(R, C) < 60 Then
  11.                 '考虑到科目和人名的字符长短不一，下面用string函数调整空格数量，来达到对齐功能
  12.                 TempStr = TempStr & Cells(1, C) & Cells(R, C) & String(6 - Len(Cells(1, C) & Cells(R, C)), "　") '把科目和不及格成绩连接
  13.                 NGCount = NGCount + 1
  14.             End If
  15.         Next
  16.         If NGCount > 2 Then Result = Result & Cells(R, 1) & String(3 - Len(Cells(R, 1)), "　") & "：" & TempStr & Chr(10)  '如果超过2门不及格，把名字连接上总字符串
  17.         TempStr = "" '单行结束后，对字符串变量置空文本
  18.         NGCount = 0 '计数器清零
  19.     Next
  20.     MsgBox "至少三科不及格者：" & Chr(10) & Result, vbInformation, "查找结果" '输出结果到信息框
  21.     Application.ScreenUpdating = True
  22. End Sub
11楼
本人号被盗，		 期盼看到罗总的10行完成，比面包同学还多5行呢。呵呵，辛苦了一天，终于出来个结果。别人看不满意，自己看已经很美了。
  1. Sub 多门不及格人员4()
  2. Dim i As Integer, j As Integer, k As Integer, fisrststr As String, laststr As String, xstr As String, rng As Range  '定义变量
  3. Set rng = ActiveSheet.UsedRange '定义rng，方便输入
  4.   For i = 2 To rng.Rows.Count  '循环所有行
  5.      k = 0:     firststr = "":   laststr = "" '每次列循环后，三项清零
  6.     For j = 1 To rng.Columns.Count  '循环所有列
  7.        If Cells(i, j) < 60 Then     '如果单元格小于60 把课目及成绩信息赋值给firststr
  8.        firststr = firststr & " " & Cells(1, j) & Cells(i, j) '用firststr记录前三次的赋值信息
  9.        k = k + 1                     '辅助变量k ，每一个不及格变量+1
  10.         If k = 3 Then                 '当变量k=3
  11.          For x3 = j + 1 To rng.Columns.Count '进入新的循环，以判断剩余的课目是否还有不及格，
  12.          If Cells(i, x3) < 60 Then            '如果不及格
  13.          laststr = laststr & " " & Cells(1, x3) & Cells(i, x3)  '用laststr记录三次以后的赋值信息
  14.          End If
  15.          Next x3
  16.          xstr = xstr & Chr(13) & Cells(i, 1) & ":  " & firststr & laststr '用xstr记录满足三次不及格的所有赋值信息，
  17.          End If
  18.         End If
  19.        Next j
  20.        Next i
  21. MsgBox "最少三门不及格的是：" & xstr '利用信息函数输出信息
  22. End Sub
12楼
大猫
  1. Sub 查找三门不合格人员()
  2.     Dim rg As Range, i%, st As String, st1 As String, rgg As Range
  3.     For i = 2 To 11
  4.         If WorksheetFunction.CountIf(Range("a" & i).Resize(1, 7), "< 60") >= 3 Then    '用CountIf判别是否有3个小于60的数据
  5.             st = ""    '清空变量，以便记录下一个数据
  6.             For Each rg In Range("a" & i).Resize(1, 7)
  7.                 If rg < 60 Then
  8.                     Set rgg = rg.Offset(-i + 1, 0)    '利用Offset偏移行查找课目名称
  9.                     st = st & " " & rgg & rg    '用&连接各个要素
  10.                 End If
  11.             Next
  12.             st1 = st1 & Chr(10) & Range("a" & i) & ":" & st    '用&Chr(10)实现名单的换行
  13.         End If
  14.     Next
  15.     MsgBox "最少三门不合格人员名单" & Chr(10) & st1, 64, "提示"
  16. End Sub
13楼
胖头鱼tx		 作业之三
第23课作业题三.zip
14楼
dofun		 Sub tt()
Dim msg As String
Dim i, K As Integer
For i = 2 To ActiveSheet.UsedRange.Rows.Count
    If Application.WorksheetFunction.CountIf(ActiveSheet.Range("b" & i & ":h" & i), "<60") >= 3 Then
        msg = msg & Cells(i, 1) & ":"
        For K = 2 To ActiveSheet.UsedRange.Columns.Count
            If ActiveSheet.Cells(i, K) < 60 Then
              msg = msg & Cells(1, K) & Cells(i, K) & vbTab
            End If
        Next K
     msg = msg & vbCrLf
     End If
Next i
MsgBox "至少三科不合格者：" & vbCrLf & msg, vbDefaultButton3, "查找结果"
End Sub
15楼
天空的雨		 Sub 查找()
Dim M As Integer     '用于存放小于60分科目数
Dim N As Integer     '用于数据区域的行数循环
Dim N1 As Integer    '用于选取数据区域的行循环
Dim N2 As Integer    '用于列号循环
Dim ST As String
ST = "至少三科不及格：" & Chr(10)
With ThisWorkbook.Sheets(1).UsedRange
    N = .Rows.Count - 1
    For N1 = 1 To N
        M = Application.WorksheetFunction.CountIf(.Offset(N1, 1).Resize(1), "<60")
        If M > 2 Then
            ST = ST & Chr(10) & Cells(N1 + 1, 1) & ": "
            For N2 = 2 To .Columns.Count
            If .Cells(N1 + 1, N2) < 60 Then
                ST = ST & .Cells(1, N2) & .Cells(N1 + 1, N2) & Space(8 - Len(Cells(1, N2) & .Cells(N1 + 1, N2)))
            End If
     Next N2
        ST = ST & Chr(10)
        End If   
Next N1
End With
MsgBox ST, vbOKOnly + vbInformation, "查找结果"
End Sub

免费听课群-天空答：第23课作业题三.rar
16楼
kcxs		 客城小生通过借鉴ynzsvt的代码终于完成了作业，在此感谢ynzsvt
  1. Sub 至少三科不及格者() '放置在模块中(借鉴ynzsvt的代码)
  2.     Dim i As Byte, j As Byte, FindCount As Byte, Rng As Range, tem As String    '声明变量
  3.     tem = "至少三科不及格者：" & Chr(10) & Chr(10) '显示信息的头部
  4.     For i = 2 To Cells(1, 1).End(xlDown).Row '从第2行到最后1行
  5.         If Application.WorksheetFunction.CountIf(Rows(i), "<60") >= 3 Then '如果每人(行)的不及格科目记录数符合条件(大于等于3)
  6.             FindCount = FindCount + 1 '统计人数
  7.             tem = tem & Cells(i, 1) & ":" & vbTab '输出姓名
  8.             For j = 2 To Cells(1, 1).End(xlToRight).Column '从第2列到最后1列
  9.                 Set Rng = Cells(i, j)
  10.                 If Rng < 60 Then tem = tem & Cells(1, Rng.Column) & Rng & vbTab '输出姓名、科目和成绩
  11.             Next j
  12.                 tem = tem & Chr(10) '不同人之间换行
  13.         End If
  14.     Next i
  15.     tem = tem & Chr(10) & "共找到" & FindCount & "位符合条件的人" '计数输出
  16.     If FindCount > 1 Then MsgBox tem, vbInformation, "查找结果" Else MsgBox "未找到符合条件的人", vbCritical, "查找结果" '输出至少三科不及格者信息
  17. End Sub

17楼
′鈊、		 Sub 至少三科不合格者() '无论当前已用区域偏移多少也能实现查找
If IsEmpty(ActiveSheet.UsedRange) Then MsgBox "工作表不能为空", 16, "温馨提示": Exit Sub '如果当前工作为空则提示用户然后退出程序
  Dim 行数 As Long, 成绩 As Byte, 科目 As String, 合并 As String, 部分合并 As String, 最终合并 As String
  Dim rng As Range, rg As Range '声明变量
      For 行数 = 1 To ActiveSheet.UsedRange.Rows.Count '从已用区域的第一行到最后一行开始循环
          Set rg = ActiveSheet.UsedRange.Rows(行数) '将已用区域的第几行赋值给变量rg
             '判断已用区域的第几行是否有3科以上不及格科目,如果满足条件,就执后面代码,否则继续就下一行
              If Application.WorksheetFunction.CountIf(rg, "< 60") >= 3 Then
                 姓名 = rg.Cells(1) '记录名字
                   For Each rng In rg.Cells '遍历已用区域的第几行里的单元格
                       If IsNumeric(rng) And rng < 60 Then '如果单元格的值是数值并且小于60,执行下面代码
                          成绩 = rng '记录成绩
                          科目 = rng.Offset(-(行数 - 1), 0) '记录科目
                          合并 = 合并 & vbTab & 科目 & 成绩 '把科目和成绩合并
                        End If
                   Next rng
                          部分合并 = 姓名 & ":" & 合并 '把姓名、科目和成绩合并
              Else: GoTo 下 '不符合条件就跳到标签处继续执行代码
              End If
                  最终合并 = 最终合并 & Chr(10) & 部分合并 '把所有三科以上不及格的人员的姓名、科目和成绩合并起来
                  合并 = "" '将变量清空,避免下次使用时产生多余字符
                  部分合并 = "" '将变量清空,避免下次使用时产生多余字符
下:   Next 行数 '设置了一个标签
         If Len(最终合并) = 0 Then '变量为0，则代表没找到条件所需的结果
            MsgBox "没找到结果", 0, "温馨提示" '提示用户没找到结果
         Else
            MsgBox "至少三科不及格者：" & Chr(13) & 最终合并, 64, "查找结果" '弹出提示框,显示查找结果
         End If
End Sub
18楼
lxmgdsdxt		 Sub 找出至少三科不合格者()
    If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub  '如果当前工作为空就退出程序
    Dim xm As String, km As String, hs As Long, ls As Integer, cj As Byte, js As Byte '声明变量
    Dim hb As String, bfhb As String, zzhb As String, zdh As Long, zdl As Integer '声明变量
      zdh = ActiveSheet.Cells(ActiveSheet.Rows.Count, ActiveSheet.UsedRange.Cells(1).Column).End(xlUp).Row '当前活动工作表已用区域的最后的一个非空行位置赋值给变量
      zdl = ActiveSheet.Cells(ActiveSheet.UsedRange.Cells(1).Row, ActiveSheet.Columns.Count).End(xlToLeft).Column '当前活动工作表已用区域的最右的一个非空列位置赋值给变量
  With ActiveSheet.UsedRange '活动工作表已用区域
    For hs = .Cells(1).Row To zdh '按行数开始循环
        For ls = .Cells(1).Column To zdl '按列数开始循环
           If Cells(hs, ls) < 60 And IsNumeric(Cells(hs, ls)) Then '如果单元格的内容是数值并且小于60
             cj = Cells(hs, ls) '记录符合条件的单元格的值
             km = Cells(.Cells(1).Row, ls) '记录对应的科目
             hb = hb & vbTab & km & cj '把科目和成绩合并
             js = js + 1 '用于计算不及格的科目数
           End If
        Next ls
              If js >= 3 Then '如果不及格的科目超过三科以上
                 xm = Cells(hs, .Cells(1).Column) '记录不及格者的姓名
                 bfhb = km & ":" & hb '姓名、科目和成绩合并
                 js = 0 '将变量清空,用于计数下一行的不及格科目数
              Else '如果不及格科目不超过三以上,跳到下一行继续查找
                 js = 0 '将变量清空,用于计数下一行的不及格科目数
                 hb = "" '将变量清空,避免下次使用时产生多余字符
                 GoTo 下一行
              End If
                zzhb = zzhb & Chr(13) & bfhb '把所有三科以上不及格的人员的姓名、科目和成绩合并起来
                 hb = "" '将变量清空,避免下次使用时产生多余字符
下一行:
    Next hs
  End With
            If Len(最终合并) = 0 Then
                   MsgBox "没找到结果", 0, "温馨提示" '提示用户没找到结果
       Else
                   MsgBox "至少三科不及格者：" & Chr(13) & zzhb, 64, "查找结果" '显示查找结果
       end if
End Sub
19楼
冰淇林的冬天		 Sub TT()
    Dim Hz As String   '变量查询信息汇总
    Dim Shuchu As String  '输出内容
    Dim Crng As Range   '变量当前使用的区域
    Dim Rng1 As Range   '变量1用于判断数据是否有问题
    Dim Rng2 As Range   '变量2用于姓名循环
    Dim Rng3 As Range   '变量3用于判断分
    Dim i As Byte      '变量I记录不及格成绩数目
    Set Crng = ActiveSheet.Range("A1").CurrentRegion      '定义变量，节省输入
    For Each Rng1 In Crng
        If IsNumeric(Rng1.Value) = True Then              '判断数据区域是否有异常数据
            If Rng1.Value < 0 Then
                MsgBox "成绩出现负数，请更正", vbOKOnly, "错误"
                Exit Sub
            ElseIf Rng1.Value > 100 Then
                MsgBox "成绩大于100，请更正", vbOKOnly, "错误"
                Exit Sub
            ElseIf Rng1.Value = "" Then
                MsgBox "发现有学生成绩为空，若是缺考，请输入零", vbOKOnly, "提示"
                Exit Sub
            End If
        ElseIf Rng1.Value = "" Then
            MsgBox "请将数据补充完毕", vbOKOnly, "错误"
            Exit Sub
        End If
    Next
    For Each Rng2 In Intersect(Crng.Columns(1).Offset(1, 0), Crng)            '循环1，在当前使用区域的学生中循环
        i = 0                                                                '重置不及格科目数
        Hz = Rng2.Value & "："                                               '重置当前学生成绩汇总
        For Each Rng3 In Intersect(Crng, Crng.Rows(Rng2.Row).Offset(0, 1))   '在rng2的学生成绩中循环
            If Rng3.Value < 60 Then
                i = i + 1                                                     '若不及格，i+1
                Hz = Hz & Rng3.Offset(-Rng3.Row + 1, 0).Value & Rng3 & "   "  '汇总不及的的科目及成绩信息
            End If
        Next
        If i >= 3 Then                                                       '若及格科目大于三科，则记到到变量输出中
            Shuchu = Shuchu & Hz & Chr(10)
        End If
    Next
    If Len(Shuchu) = 0 Then
        MsgBox "没有超过3课不及格的学生", vbOKOnly, "查找结果"
    Else
        Shuchu = "至少三科不及格者：" & Chr(10) & Shuchu
        MsgBox Shuchu, vbOKOnly + vbInformation, "差找结果"
    End If
End Sub
冰激凌的冬天
这周太忙，导致作业交晚了，抱歉`
20楼
mmice		 Sub 提取三科成绩不合格名单1()
    Dim 姓名 As Byte, 科目 As Byte, msg As String, 计数 As Byte, str As String, Result As String
    For 姓名 = 2 To Cells(Rows.Count, 1).End(xlUp).Row '按姓名逐行查找
        For 科目 = 2 To Cells(1, Columns.Count).End(xlToLeft).Column '按科目逐列查找
            If Cells(姓名, 科目) < 60 Then
                str = str & Cells(1, 科目) & Cells(姓名, 科目) & String(6 - Len(Cells(1, 科目) & Cells(姓名, 科目)), "　") '科目和成绩，外加空格对齐
                计数 = 计数 + 1
            End If
         Next
                    If 计数 > 2 Then If 计数 > 2 Then Result = Result & Cells(姓名, 1) & String(3 - Len(Cells(姓名, 1)), "　") & "：" & str & Chr(10)'当列个数大于2，符合至少三科不合格
                    str = "" '要清空，不然不对
                    计数 = 0 '要清空，继续下行计数
     Next
    MsgBox Result, 64, "查找结果"
End Sub


群名片：鼠小白
21楼
manuel442		 Sub 至少三科不及格()
Dim rng As Range
Dim erng As Range
Dim ecell As Range
Dim msg As String
Set rng = Sheets(1).UsedRange '获取处理区域
For Each erng In rng.Rows       '先对区域按行遍历
    If Application.WorksheetFunction.CountIf(erng, "<60") >= 3 Then '按行判断是否符合条件
    msg = msg & erng.Cells(1).Value & "：" '对符合条件的先添加姓名
    For Each ecell In erng.Cells            '对符合条件的行遍历，取出科目分数小于60的科目
        If ecell.Value < 60 Then
            msg = msg & ecell.End(xlUp).Value & ecell & vbTab '将科目分数小于60的依次合并
        End If
    Next
    msg = msg & Chr(10)    '结果换行
    End If
Next
MsgBox "至少三科不及格者：" & Chr(10) & msg, vbInformation, "查找结果" '输出结果
End Sub

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap