|
- Option Explicit
- Sub 单份提取()
- Rem 此过程每次读取一份由数据库中提取出来的数据
- Rem 如果年级工作表存在,则得出的结果插入顶部,否则创建新工作表并命名为年级
- Dim LastRec As Long, i As Long, j As Long
- Dim Score As Variant '成绩
- Dim n As Integer, m As Integer, p As Integer, Cnt As Integer
- Dim Term As String, Grade As String '学期、年级
- Dim FileName As String
- Dim d As Object
- Dim Wb As Workbook, Sht As Worksheet, Rng As Range, ttRows As Range
- Dim Arr, Result()
- FileName = Application.GetOpenFilename
- If Len(FileName) = 0 Then Exit Sub
- Application.ScreenUpdating = False
- Set Wb = Workbooks.Open(FileName)
- Set Sht = Wb.ActiveSheet
- LastRec = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
- Grade = Left(Sht.Name, 5) '得到年级信息
- Rem 排序,将第一学期和第二学期分开,方便处理
- Sht.Range("A:L").Sort key1:=Sht.Range("F2"), order1:=xlDescending, key2:=Sht.Range("B2"), order2:=xlAscending, Header:=xlYes
- Arr = Sht.Range("A1:L" & LastRec + 1) '读取排序后的数据
- Wb.Close 0
- Set Wb = Nothing: Set Sht = Nothing
- On Error Resume Next
- If ThisWorkbook.Sheets(Grade) Is Nothing Then
- ThisWorkbook.Sheets.Add
- ActiveSheet.Name = Grade
- Else
- If MsgBox("该年级工作表已经存在,可能会造成数据重复,是否继续?", vbInformation + vbYesNo) = vbYes Then
- ThisWorkbook.Sheets(Grade).Activate
- If MsgBox("是否删除原有数据?", vbInformation + vbYesNo) = vbYes Then Cells.Delete
- Else
- Exit Sub
- End If
- End If
- On Error GoTo 0
- Set d = CreateObject("scripting.dictionary")
- ReDim Result(1 To LastRec, 1 To 25)
- p = InputBox("选择不及格科目数") '确定条件
- If Len(p) = 0 Or Not IsNumeric(p) Then Exit Sub
- p = Val(p)
- For i = 2 To LastRec
- If Arr(i, 6) = "第一学期" Then
- Term = Arr(i, 5) & "(一)"
- ElseIf Arr(i, 6) = "第二学期" Then
- Term = Arr(i, 5) & "(二)"
- End If
- 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 < p Then '如果该学生不及格科目<p,则删除该行记录
- For j = 1 To 25
- Result(n, j) = ""
- Next j
- n = n - 1
- End If
- Cnt = 0 '不及格数归零
- End If
- Next i
- If n = 0 Then Exit Sub
- 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, ActiveSheet.UsedRange).Interior.ColorIndex = 42
- Rng.Delete
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|