|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- mc = Application.InputBox(prompt:="请输入需要筛选的名次:", Title:="操作提示", Default:=30, Type:=1)
- With Worksheets("成绩录入")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(2, .Columns.Count).End(xlToLeft).Column
- arr = .Range("a2").Resize(r - 1, c)
- End With
- For i = 2 To UBound(arr)
- If arr(i, 16) <= mc Then
- If Not d.exists(arr(i, 1)) Then
- m = 1
- ReDim brr(1 To UBound(arr, 2), 1 To m)
- Else
- brr = d(arr(i, 1))
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
- End If
- For j = 1 To UBound(arr, 2)
- brr(j, m) = arr(i, j)
- Next
- d(arr(i, 1)) = brr
- End If
- Next
- For Each aa In d.keys
- brr = d(aa)
- ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
- For i = 1 To UBound(brr)
- For j = 1 To UBound(brr, 2)
- crr(j, i) = brr(i, j)
- Next
- Next
- shtname = Application.Text(aa, "[DBNum1]") & "年级前" & mc & "名单"
- On Error Resume Next
- Set ws = Worksheets(shtname)
- If Err Then
- Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
- ws.Name = shtname
- End If
- On Error GoTo 0
- With ws
- .Cells.Clear
- .Range("a1").Resize(1, UBound(arr, 2)) = Application.Index(arr, 1, 0)
- .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
- With .Range("a1").Resize(1 + UBound(crr), UBound(crr, 2))
- .Borders.LineStyle = xlContinuous
- With .Font
- .Name = "微软雅黑"
- .Size = 11
- End With
- End With
- .Columns(1).Resize(, UBound(crr, 2)).AutoFit
- .Range("a1").Resize(1 + UBound(crr), UBound(crr, 2)).Sort key1:=.Cells(1, UBound(crr, 2)), order1:=xlAscending, Header:=xlYes
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- Next
- Application.ScreenUpdating = True
- MsgBox "成绩统计完毕!"
- End Sub
复制代码 |
|