|
结果输出到A:E列,两种方法均可行。- Sub 筛选数据2()
- '---------------------------------------------------------------------------------------
- ' Procedure : 筛选数据2
- ' Author : hwc2ycy
- ' Date : 2013/2/18
- ' Purpose : 静态数组
- '---------------------------------------------------------------------------------------
- '
- Dim arr
- Dim LastRow&, Record&
- Dim i&, j&
- Dim result()
- Dim title()
- Application.ScreenUpdating = False
- title = Array("学号", "姓名", "课程", "正考", "补考")
- With Worksheets("源数据")
- LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
- arr = .Range("a5:s" & LastRow)
- End With
- ReDim result(1 To UBound(arr) * 8, 1 To 5)
- For i = LBound(arr) + 3 To UBound(arr)
- For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
- If arr(i, j) < 60 Or arr(i, j) = "缺" Then
- Record = Record + 1
- result(Record, 1) = "'" & arr(i, 2)
- result(Record, 2) = arr(i, 3)
- result(Record, 3) = arr(1, j)
- result(Record, 4) = arr(i, j)
- If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
- result(Record, 5) = arr(i, j + 1)
- End If
- End If
- Next
- Next
- With Worksheets("补考名单")
- .Range("a1").CurrentRegion = ""
- .Range("a2").Resize(Record, 5) = result
- .Range("a1").Resize(, 5) = title
- .Columns("a:e").AutoFit
- .Columns("a:e").HorizontalAlignment = xlCenter
- End With
- Application.ScreenUpdating = True
- MsgBox "提取完成"
- End Sub
- Sub 筛选数据()
- '---------------------------------------------------------------------------------------
- ' Procedure : 筛选数据
- ' Author : hwc2ycy
- ' Date : 2013/2/18
- ' Purpose : 动态数组
- '---------------------------------------------------------------------------------------
- '
- Dim arr
- Dim LastRow&, Record&
- Dim i&, j&
- Dim result()
- Dim title()
- Application.ScreenUpdating = False
- title = Array("学号", "姓名", "课程", "正考", "补考")
- With Worksheets("源数据")
- LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
- arr = .Range("a5:s" & LastRow)
- End With
- ReDim result(1 To 5, 1 To 1)
- For i = LBound(arr) + 3 To UBound(arr)
- For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
- If arr(i, j) < 60 Or arr(i, j) = "缺" Then
- Record = Record + 1
- ReDim Preserve result(1 To 5, 1 To Record)
- result(1, Record) = "'" & arr(i, 2)
- result(2, Record) = arr(i, 3)
- result(3, Record) = arr(1, j)
- result(4, Record) = arr(i, j)
- If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
- result(5, Record) = arr(i, j + 1)
- End If
- End If
- Next
- Next
- With Worksheets("补考名单")
- .Range("a1").CurrentRegion = ""
- .Range("a2").Resize(Record, 5) = WorksheetFunction.Transpose(result)
- .Range("a1").Resize(, 5) = title
- .Columns("a:e").AutoFit
- .Columns("a:e").HorizontalAlignment = xlCenter
- End With
- Application.ScreenUpdating = True
- MsgBox "提取完成"
- End Sub
复制代码 |
|