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

qingc0221 · 发表于 2017-6-23 22:46

除了2012-2013(一)2012级补考后成绩.xls,其他都搞定了
草图.png

mzbao · 发表于 2017-6-23 23:07

本帖最后由 mzbao 于 2017-6-23 23:21 编辑

闲来无事，做了个，你看看是不是你要的。

ps90025505 · 发表于 2017-6-24 10:00

本帖最后由 ps90025505 于 2017-6-24 20:14 编辑

mzbao 发表于 2017-6-23 23:07
闲来无事，做了个，你看看是不是你要的。

太牛x了，，大概就这个样子，就行了，，，能教我怎么操作吗？我就这样的方式交给领导算了。。。这是超过3门的，再教我一下，超过多少门，的数字在哪里修改，就行了。。超过3门太多了，，估计领导还需要知道超过4门 5 门之类的。
我刚才试着做了一下，前面学期及格后面不及格的，会出现在下面，，这样的话，我a列是不是排序一下，就是一个班的，到一起了。。不会乱吧。。

我用分列的方法去排序了。这样，学号3会排在13号后面，，如果能在单个数据3搞成03就更完美了，

如果要修改科目增加到5门是修改这个数值吗。。

发现有些学生，比如第一学期及格了，第二学期及格，第三学期，第四学期不及格的，，在data里面有，，但是抓取不到第一张汇总sheet表中。。

宝贝万岁 · 发表于 2017-6-24 12:47

qingc0221 发表于 2017-6-23 22:46
除了2012-2013(一)2012级补考后成绩.xls,其他都搞定了

太牛X，上个附件学习下呗~

ps90025505 · 发表于 2017-6-24 13:11

我太喜欢这个论坛了，我们单位处在一个60年代的纯手工工作模式，搞系统又不搞，还天天学别人的这个花样，那个花样，我了个去。。。整天就是折腾人玩。。

qingc0221 · 发表于 2017-6-24 15:08

尝试上传附件就退出登录,正常回复就没有问题..........

qingc0221 · 发表于 2017-6-24 15:40

Option Explicit
Dim i As Integer, j As Integer, k As Integer
Dim Score As Variant '成绩
Dim n As Integer, p As Integer, Cnt As Integer
Dim LastRec As Long, LastCol As Long
Dim Term As String, Grade As String, Cls As String '学期、年级、班级
Dim Path As String, FileName As String
Dim Wb As Workbook, Sht As Worksheet, Rng As Range, ttRows As Range
Dim Arr, Result()
Sub 提取数据()
Rem 提取各年级各班级中不及格科目>=3的学生信息,按年级分类存放
Rem 每次运行提取一个年级的数据,剔除及格的成绩
Rem 因工作簿"2012-2013(一)2012级补考后成绩.xls"中工作表名称非数字,代码自动忽略
With Application.FileDialog(msoFileDialogFolderPicker) '选择年级文件夹
.Title = "选择年级文件夹"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
Path = .SelectedItems(1) & ""
End If
End With
Application.ScreenUpdating = False
Grade = Right(Path, 8)
Grade = Left(Grade, 5) '在文件名中获取年级
On Error Resume Next
If ThisWorkbook.Sheets(Grade) Is Nothing Then '该年级工作表不存在则创建新表
ThisWorkbook.Sheets.Add '新增年级工作表
ThisWorkbook.ActiveSheet.Name = Grade
Else '该年级工作表存在则退出
MsgBox "该年级工作表已存在!" & vbCrLf & "如需继续,请先删除该工作表" & vbCrLf & "或重命名以防止表名冲突"
Exit Sub
End If
On Error GoTo 0
ReDim Result(1 To 10000, 1 To 25)
FileName = Dir(Path & "*.xls*")
n = 0: Cnt = 0
Do While Len(FileName) <> 0
If Left(FileName, 1) <> "." Then
p = InStr(FileName, ")")
Term = Left(FileName, p)
Set Wb = Workbooks.Open(Path & FileName)
For Each Sht In Wb.Worksheets
If IsNumeric(Sht.Name) Then '表名为班号,都是数字
Cls = Sht.Name
Arr = Sht.Range("A2").CurrentRegion
LastRec = UBound(Arr, 1) - 1 '最后一条记录行号,除去汇总行
LastCol = UBound(Arr, 2) '最大列号
Rem ---------添加班级标题行开始------------
Rem 只要是新的班级就添加标题行,不管该班级有没有符合条件的数据
Rem 所以会出现多余的标题行,需后续处理
n = n + 2
Result(n, 1) = "学期"
Result(n, 2) = "班级"
Result(n, 3) = "学号"
Result(n, 4) = "姓名"
For k = 3 To LastCol
Result(n, k + 2) = Arr(3, k)
Next k
Rem ---------添加班级标题行结束------------
For i = 5 To LastRec
Cnt = 0
For j = 3 To LastCol
Score = Arr(i, j)
If IsNumeric(Score) Then '成绩为数字的情形
If Score >= 60 Then
Arr(i, j) = "" '把及格的分数替换为""
Else
Cnt = Cnt + 1
End If
Else '成绩为非数字类型
If Trim(Score) = "及格" Then '用Trim防止文字中含有空格
Arr(i, j) = "" '把"及格"替换为""
Else
Cnt = Cnt + 1
End If
End If
Next j
If Cnt >= 3 Then '如果某同学有3科以上不及格则输出结果
n = n + 1
Result(n, 1) = Term '学期
Result(n, 2) = Cls '班级
Result(n, 3) = Cls & Format(Arr(i, 1), "00") '学号=班级+序号
Result(n, 4) = Arr(i, 2) '姓名
For k = 3 To LastCol '各科成绩
Result(n, k + 2) = Arr(i, k)
Next k
End If
Next i
End If
Next Sht
Wb.Close 1
End If
FileName = Dir
Loop
Set Wb = Nothing
Set Sht = Nothing
Set Rng = Rows(1) '多余的标题行,即某班没有符合的数据
Set ttRows = Rows(2) '正常标题行,用于字体加粗和填充颜色
For i = 1 To n
If Result(i, 1) = "学期" Then
If Result(i + 1, 1) = "" Then
Set Rng = Union(Rng, Rows(i), Rows(i + 1))
Else
Set ttRows = Union(ttRows, Rows(i))
End If
End If
Next i
Rem 输出结果
ThisWorkbook.Sheets(Grade).Range("A1").Resize(n, 25) = Result
Rem 标题行字体加粗并填充颜色
ttRows.Font.Bold = True
Intersect(ttRows, ThisWorkbook.Sheets(Grade).UsedRange).Interior.ColorIndex = 42
Rem 删除多余行
Rng.Delete
Application.ScreenUpdating = True
End Sub
Sub 提取单张工作簿()
Rem 运行上面的代码得到"2012级"工作表后再运行此代码
Rem "2012-2013(一)2012级补考后成绩.xls"中有7条"第二学期"的数据,已先行挪到新工作表,后续手工添加即可
Rem 功能:将"2012-2013(一)2012级补考后成绩.xls"中的满足条件的数据提取到工作表"2012级"的顶部
Dim LastRow As Long, m As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Path = ThisWorkbook.Path & ""
FileName = Path & "2012级成绩\2012-2013(一)2012级补考后成绩.xls"
Application.ScreenUpdating = False
Set Wb = Workbooks.Open(FileName)
Set Sht = Wb.Sheets("2012级成绩")
LastRow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
Arr = Sht.Range("A1:L" & LastRow + 1)
Wb.Close 1
Set Wb = Nothing
Set Sht = Nothing
ReDim Result(1 To UBound(Arr), 1 To 25)
Term = "2012-2013(一)"
n = 0: Cnt = 0
For i = 2 To LastRow - 1
If Arr(i, 1) <> Arr(i - 1, 1) Then '跳转到另一个班级
Rem ---------添加班级标题行开始------------
n = n + 2
Result(n, 1) = "学期"
Result(n, 2) = "班级"
Result(n, 3) = "学号"
Result(n, 4) = "姓名"
d.RemoveAll
m = 0
Do While Arr(i + m, 2) = Arr(i, 2)
Result(n, 5 + m) = Arr(i + m, 12)
d(Arr(i + m, 12)) = m
m = m + 1
Loop
Rem ---------添加班级标题行结束------------
End If
If Arr(i, 2) <> Arr(i - 1, 2) Then '另一位学生
n = n + 1 '换行,并添加学生信息
Result(n, 1) = Term '学期
Result(n, 2) = Arr(i, 1) '班级
Result(n, 3) = Arr(i, 2) '学号
Result(n, 4) = Arr(i, 3) '姓名
End If
m = d(Arr(i, 12)) + 5 '科目对应的列号
If Arr(i, 7) >= 60 Then
Result(n, m) = ""
Else
Cnt = Cnt + 1
If Arr(i, 8) = "" Then
Result(n, m) = Arr(i, 7)
Else
Result(n, m) = Arr(i, 8)
End If
End If
If Arr(i, 2) <> Arr(i + 1, 2) Then '已到该学生最后一条数据
If Cnt < 3 Then '如果该学生不及格科目<3,则删除改行记录
For k = 1 To 25
Result(n, k) = ""
Next k
n = n - 1
End If
Cnt = 0 '不及格计数归零
End If
Next i
Range(Rows(1), Rows(n + 1)).Insert
Range("A1").Resize(n, 25) = Result
Set Rng = Rows(1)
Set ttRows = Rows(2)
For i = 1 To n '删除多余的标题
If Result(i, 1) = "学期" Then
If Result(i + 1, 1) = "" Then
Set Rng = Union(Rng, Rows(i), Rows(i + 1))
Else
Set ttRows = Union(ttRows, Rows(i))
End If
End If
Next i
ttRows.Font.Bold = True
Intersect(ttRows, Range("A:N")).Interior.ColorIndex = 42
Rng.Delete
Application.ScreenUpdating = True
End Sub

复制代码

qingc0221 · 发表于 2017-6-24 15:43

上代码没问题,审核中
上传附件就退出登录

ps90025505 · 发表于 2017-6-24 19:36

本帖最后由 ps90025505 于 2017-6-24 19:41 编辑

qingc0221 发表于 2017-6-24 15:43
上代码没问题,审核中
上传附件就退出登录

我的qq 504917770 你qq多少，加我一下。我添加代码运行，出现错误。。不知道怎么搞了。

qingc0221 · 发表于 2017-6-24 21:09

成绩.7z (1.08 MB, 下载次数: 11)

		自动登录	找回密码
密码			免费注册

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

最新热点 /1

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

最新热点 /1

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