ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: ps90025505

[求助] 在线等各位大神帮我一下 关于数据筛选

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-24 21:53 | 显示全部楼层

这是按学期,刷三门不及格科目,只要达标列出来,,然后,每个表重复是不是呀,,,,但是这样,一个人会再现在几个学期当中,,不在一起,,怎么让同一个班的人,几个学期排在一起呢?

TA的精华主题

TA的得分主题

发表于 2017-6-24 21:57 | 显示全部楼层
ps90025505 发表于 2017-6-24 21:53
这是按学期,刷三门不及格科目,只要达标列出来,,然后,每个表重复是不是呀,,,,但是这样,一个人会 ...

每个学期的课程又不一样

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-24 22:14 | 显示全部楼层
本帖最后由 ps90025505 于 2017-6-24 22:24 编辑
qingc0221 发表于 2017-6-24 21:57
每个学期的课程又不一样

确实,,我头大了。。要疯了。。在程序哪里修改科目的数量呀。。比如要求 5门 6门的
我的操作是 打开文档 alt+f8 点击提取数据 选择年级文件夹 让他运行就行了吧     还有一个 提取单张工作薄 不用管它 是不是呀!

TA的精华主题

TA的得分主题

发表于 2017-6-24 22:34 | 显示全部楼层
If Cnt >= 3 Then    '如果某同学有3科以上不及格则输出结果
上面的3改成你要的数量就行

你有一个工作簿使用软件导出的,我用 Sub 提取单张工作簿()  来提取出来,并放到"2012级"的顶端,如果你不需要这个工作簿的数据,可以不运行它。如果你要改数量的话,这段代码中
If Cnt < 3 Then                '如果该学生不及格科目<3,则删除该行记录
上面的3也要改

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-25 06:03 来自手机 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
谢谢了 ,我今天再操作操作!

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-25 10:18 | 显示全部楼层
本帖最后由 ps90025505 于 2017-6-25 10:32 编辑
qingc0221 发表于 2017-6-24 22:34
If Cnt >= 3 Then    '如果某同学有3科以上不及格则输出结果
上面的3改成你要的数量就行

帮我修改一下,11级这种系统 导出成绩的 数据提取,,我修改了,你的路径,出错了。。。不知道怎么修改了。
能加我一下 qq 504917770 吗?帮我改良一个xla,,也是论坛里面一位大神做的。。我的那个帐号登录不了,找不到了。。。只有代码了!

成绩5门科目测试.7z

1.57 MB, 下载次数: 1

TA的精华主题

TA的得分主题

发表于 2017-6-25 19:22 | 显示全部楼层
路径对了没用,之前那份只有一个学期,所以我没有判断学期就直接读取,现在这份有两个学期,所以要该代码才能用

TA的精华主题

TA的得分主题

发表于 2017-6-26 00:20 | 显示全部楼层
重新改了一下,取消路径和不及格数量的硬编码
  1. Option Explicit

  2. Sub 批量提取()
  3. Rem   提取各年级各班级中不及格科目>=3的学生信息,按年级分类存放
  4. Rem   每次运行提取一个年级的数据,剔除及格的成绩
  5. Rem   因系统导出数据的工作簿的工作表名称非数字,代码自动忽略
  6.     Dim i As Integer, j As Integer, k As Integer
  7.     Dim Score As Variant    '成绩
  8.     Dim n As Integer, m As Integer, p As Integer, Cnt As Integer
  9.     Dim LastRec As Long, LastCol As Long
  10.     Dim Term As String, Grade As String, Cls As String  '学期、年级、班级
  11.     Dim Path As String, FileName As String
  12.     Dim Msg As String
  13.     Dim Wb As Workbook, Sht As Worksheet, Rng As Range, ttRows As Range
  14.     Dim Arr, Result()
  15.     With Application.FileDialog(msoFileDialogFolderPicker) '选择年级文件夹
  16.         .Title = "选择年级文件夹"
  17.         .Show
  18.         If .SelectedItems.Count = 0 Then
  19.             Exit Sub
  20.         Else
  21.             Path = .SelectedItems(1) & ""
  22.         End If
  23.     End With
  24.     Application.ScreenUpdating = False
  25.     Grade = Right(Path, 8)
  26.     Grade = Left(Grade, 5)  '在文件名中获取年级
  27.     On Error Resume Next
  28.     If ThisWorkbook.Sheets(Grade) Is Nothing Then   '该年级工作表不存在则创建新表
  29.         ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) '新增年级工作表
  30.         ActiveSheet.Name = Grade
  31.     Else
  32.         Msg = "该年级工作表已存在!" & vbCrLf & "是否继续?"
  33.         If MsgBox(Msg, vbInformation + vbYesNo) = vbYes Then
  34.             ThisWorkbook.Sheets(Grade).Activate
  35.             Msg = "是否清空原有数据?" & vbCrLf & "如不清空,则结果在原有数据顶部写入"
  36.             If MsgBox(Msg, vbInformation + vbYesNo) = vbYes Then Cells.Delete
  37.         Else
  38.             MsgBox "您选择了""否"",程序退出"
  39.             Exit Sub
  40.         End If
  41.     End If
  42.     On Error GoTo 0
  43.     ReDim Result(1 To 10000, 1 To 25)
  44.     p = InputBox("选择不及格科目数")    '确定条件
  45.     If Len(p) = 0 Or Not IsNumeric(p) Then Exit Sub
  46.     p = Val(p)
  47.     FileName = Dir(Path & "*.xls*")
  48.     Do While Len(FileName) <> 0
  49.         If Left(FileName, 1) <> "." Then
  50.             m = InStr(FileName, ")")
  51.             Term = Left(FileName, m)
  52.             Set Wb = Workbooks.Open(Path & FileName)
  53.             For Each Sht In Wb.Worksheets
  54.                 If IsNumeric(Sht.Name) Then '表名为班号,都是数字
  55.                     Cls = Sht.Name
  56.                     Arr = Sht.Range("A2").CurrentRegion
  57.                     LastRec = UBound(Arr, 1) - 1    '最后一条记录行号,除去汇总行
  58.                     LastCol = UBound(Arr, 2)        '最大列号
  59.                     Rem ---------添加班级标题行开始------------
  60.                     Rem 只要是新的班级就添加标题行,不管该班级有没有符合条件的数据
  61.                     Rem 所以会出现多余的标题行,需后续处理
  62.                     n = n + 2
  63.                     Result(n, 1) = "学期"
  64.                     Result(n, 2) = "班级"
  65.                     Result(n, 3) = "学号"
  66.                     Result(n, 4) = "姓名"
  67.                     For k = 3 To LastCol
  68.                         Result(n, k + 2) = Arr(3, k)
  69.                     Next k
  70.                     Rem ---------添加班级标题行结束------------
  71.                     For i = 5 To LastRec
  72.                         Cnt = 0
  73.                         For j = 3 To LastCol
  74.                             Score = Arr(i, j)
  75.                             If IsNumeric(Score) Then    '成绩为数字的情形
  76.                                 If Score >= 60 Then
  77.                                     Arr(i, j) = ""  '把及格的分数替换为""
  78.                                 Else
  79.                                     Cnt = Cnt + 1
  80.                                 End If
  81.                             Else                    '成绩为非数字类型
  82.                                 If Trim(Score) = "及格" Then '用Trim防止文字中含有空格
  83.                                     Arr(i, j) = ""  '把"及格"替换为""
  84.                                 Else
  85.                                     Cnt = Cnt + 1
  86.                                 End If
  87.                             End If
  88.                         Next j
  89.                         If Cnt >= p Then    '如果某同学有3科以上不及格则输出结果
  90.                             n = n + 1
  91.                             Result(n, 1) = Term '学期
  92.                             Result(n, 2) = Cls  '班级
  93.                             Result(n, 3) = Cls & Format(Arr(i, 1), "00")    '学号=班级+序号
  94.                             Result(n, 4) = Arr(i, 2)    '姓名
  95.                             For k = 3 To LastCol    '各科成绩
  96.                                 Result(n, k + 2) = Arr(i, k)
  97.                             Next k
  98.                         End If
  99.                     Next i
  100.                 End If
  101.             Next Sht
  102.             Wb.Close 1
  103.         End If
  104.         FileName = Dir
  105.     Loop
  106.     Set Wb = Nothing
  107.     Set Sht = Nothing
  108.     Set Rng = Rows(1)   '多余的标题行,即某班没有符合的数据
  109.     Set ttRows = Rows(2) '正常标题行,用于字体加粗和填充颜色
  110.     For i = 1 To n
  111.         If Result(i, 1) = "学期" Then
  112.             If Result(i + 1, 1) = "" Then
  113.                 Set Rng = Union(Rng, Rows(i), Rows(i + 1))
  114.             Else
  115.                 Set ttRows = Union(ttRows, Rows(i))
  116.             End If
  117.         End If
  118.     Next i
  119.     Rem 输出结果
  120.     If n = 0 Then Exit Sub
  121.     Range(Rows(1), Rows(n + 1)).Insert
  122.     Range("A1").Resize(n, 25) = Result
  123.     Rem 标题行字体加粗并填充颜色
  124.     ttRows.Font.Bold = True
  125.     Intersect(ttRows, ActiveSheet.UsedRange).Interior.ColorIndex = 42
  126.     Rem 删除多余行
  127.     Rng.Delete
  128.     Application.ScreenUpdating = True
  129. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2017-6-26 00:21 | 显示全部楼层
  1. Option Explicit

  2. Sub 单份提取()
  3. Rem 此过程每次读取一份由数据库中提取出来的数据
  4. Rem 如果年级工作表存在,则得出的结果插入顶部,否则创建新工作表并命名为年级
  5.     Dim LastRec As Long, i As Long, j As Long
  6.     Dim Score As Variant    '成绩
  7.     Dim n As Integer, m As Integer, p As Integer, Cnt As Integer
  8.     Dim Term As String, Grade As String  '学期、年级
  9.     Dim FileName As String
  10.     Dim d As Object
  11.     Dim Wb As Workbook, Sht As Worksheet, Rng As Range, ttRows As Range
  12.     Dim Arr, Result()
  13.     FileName = Application.GetOpenFilename
  14.     If Len(FileName) = 0 Then Exit Sub
  15.     Application.ScreenUpdating = False
  16.     Set Wb = Workbooks.Open(FileName)
  17.     Set Sht = Wb.ActiveSheet
  18.     LastRec = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
  19.     Grade = Left(Sht.Name, 5) '得到年级信息
  20.     Rem 排序,将第一学期和第二学期分开,方便处理
  21.     Sht.Range("A:L").Sort key1:=Sht.Range("F2"), order1:=xlDescending, key2:=Sht.Range("B2"), order2:=xlAscending, Header:=xlYes
  22.     Arr = Sht.Range("A1:L" & LastRec + 1) '读取排序后的数据
  23.     Wb.Close 0
  24.     Set Wb = Nothing: Set Sht = Nothing
  25.     On Error Resume Next
  26.     If ThisWorkbook.Sheets(Grade) Is Nothing Then
  27.         ThisWorkbook.Sheets.Add
  28.         ActiveSheet.Name = Grade
  29.     Else
  30.         If MsgBox("该年级工作表已经存在,可能会造成数据重复,是否继续?", vbInformation + vbYesNo) = vbYes Then
  31.             ThisWorkbook.Sheets(Grade).Activate
  32.             If MsgBox("是否删除原有数据?", vbInformation + vbYesNo) = vbYes Then Cells.Delete
  33.         Else
  34.             Exit Sub
  35.         End If
  36.     End If
  37.     On Error GoTo 0
  38.     Set d = CreateObject("scripting.dictionary")
  39.     ReDim Result(1 To LastRec, 1 To 25)
  40.     p = InputBox("选择不及格科目数")    '确定条件
  41.     If Len(p) = 0 Or Not IsNumeric(p) Then Exit Sub
  42.     p = Val(p)
  43.     For i = 2 To LastRec
  44.         If Arr(i, 6) = "第一学期" Then
  45.             Term = Arr(i, 5) & "(一)"
  46.         ElseIf Arr(i, 6) = "第二学期" Then
  47.             Term = Arr(i, 5) & "(二)"
  48.         End If
  49.         If Arr(i, 1) <> Arr(i - 1, 1) Then  '跳转到另一个班级
  50.             Rem ---------添加班级标题行开始------------
  51.             n = n + 2
  52.             Result(n, 1) = "学期"
  53.             Result(n, 2) = "班级"
  54.             Result(n, 3) = "学号"
  55.             Result(n, 4) = "姓名"
  56.             d.RemoveAll
  57.             m = 0
  58.             Do While Arr(i + m, 2) = Arr(i, 2)
  59.                 Result(n, 5 + m) = Arr(i + m, 12)
  60.                 d(Arr(i + m, 12)) = m
  61.                 m = m + 1
  62.             Loop
  63.             Rem ---------添加班级标题行结束------------
  64.         End If
  65.         If Arr(i, 2) <> Arr(i - 1, 2) Then  '另一位学生
  66.             n = n + 1                       '换行,并添加学生信息
  67.             Result(n, 1) = Term             '学期
  68.             Result(n, 2) = Arr(i, 1)        '班级
  69.             Result(n, 3) = Arr(i, 2)        '学号
  70.             Result(n, 4) = Arr(i, 3)        '姓名
  71.         End If
  72.         m = d(Arr(i, 12)) + 5               '科目对应的列号
  73.         If Arr(i, 7) >= 60 Then
  74.             Result(n, m) = ""
  75.         Else
  76.             Cnt = Cnt + 1
  77.             If Arr(i, 8) = "" Then
  78.                 Result(n, m) = Arr(i, 7)
  79.             Else
  80.                 Result(n, m) = Arr(i, 8)
  81.             End If
  82.         End If
  83.         If Arr(i, 2) <> Arr(i + 1, 2) Then  '已到该学生最后一条数据
  84.             If Cnt < p Then                '如果该学生不及格科目<p,则删除该行记录
  85.                 For j = 1 To 25
  86.                     Result(n, j) = ""
  87.                 Next j
  88.                 n = n - 1
  89.             End If
  90.             Cnt = 0                         '不及格数归零
  91.         End If
  92.     Next i
  93.     If n = 0 Then Exit Sub
  94.     Range(Rows(1), Rows(n + 1)).Insert
  95.     Range("A1").Resize(n, 25) = Result
  96.     Set Rng = Rows(1)
  97.     Set ttRows = Rows(2)
  98.     For i = 1 To n  '删除多余的标题
  99.         If Result(i, 1) = "学期" Then
  100.             If Result(i + 1, 1) = "" Then
  101.                 Set Rng = Union(Rng, Rows(i), Rows(i + 1))
  102.             Else
  103.                 Set ttRows = Union(ttRows, Rows(i))
  104.             End If
  105.         End If
  106.     Next i
  107.     ttRows.Font.Bold = True
  108.     Intersect(ttRows, ActiveSheet.UsedRange).Interior.ColorIndex = 42
  109.     Rng.Delete
  110.     Application.ScreenUpdating = True
  111. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-26 14:36 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

我把代码放出去,怎么总是出错呀,,能按我的原表几个文件,打个包,给我吗,,压缩小于2m就能上传了。。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 15:52 , Processed in 0.059941 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表