Sub 把成绩分班()
Dim r, j, c, s, t As Integer
Worksheets(1).Activate
Range("a1:k151").Sort
key1:=Range("a1"), Order1:=xlAscending, Header:=xlYes
'创建班级人数的数组
Dim cArr(6) As
Integer
cArr(1) = 32
cArr(2) = 31
cArr(3) = 24
cArr(4) = 20
cArr(5) = 20
cArr(6) = 23
'按班级人数设置分页符
s = 2
For ii = 1 To 6
s = cArr(ii) + s
Range("a" &
s).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add
before:=ActiveCell
'ActiveSheet.ResetAllPageBreaks
Next ii
'创建空表并命名
num =
ActiveSheet.[b65536].End(xlUp).Row
'num =
ActiveSheet.UsedRange.Rows.Count
For j = 1 To 6
Worksheets.Add
after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = j &
"班"
.Rows(1).Value =
Worksheets(1).Rows(1).Value
End With
Next j
'复制指定抬头
'For c = 1 To 8
'Sheets(j &
"班").Cells(1, c).Value = workSheets(1).Cells(1, c).Value
'Next c
'给空表赋值
For j = 1 To 6
s = 0
For r = 2 To num
'记录学生排名，存储为s
If
Worksheets(1).Cells(r, 1).Value = j Then
s = s + 1
'累计记录数
'Sheets(j &
"班").Cells(s + 1, 1).Value = s
'复制成绩
Sheets(j &
"班").Rows(s + 1).Value = Worksheets(1).Rows(r).Value
End If
Next r
Next j
'以下排序、设置列宽、对齐
For j = 1 To 6
Worksheets(j &
"班").Activate
num =
ActiveSheet.UsedRange.Rows.Count
With Sheets(j & "班").Range("a:k")
.Sort key1:=Range("k1"), Order1:=xlAscending,
Header:=xlYes
.Sort key1:=Range("a1"), Order1:=xlAscending,
Header:=xlYes
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Sheets(j &
"班")
.Columns.ColumnWidth =
4.5
.Columns(2).ColumnWidth
= 7.5
With .Range("a1:k" & num).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
Next j
End Sub
Sub 清除各项杂表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sht As Worksheet
Dim th As Workbook
Set th = ThisWorkbook
For Each sht In th.Sheets
If sht.Name <> Sheet1.Name Then
sht.Delete
End If
Next
End Sub
Sub 把成绩分学科()
Dim r, bj, c, s, kemu As Integer
'创建学科数组
Dim cArr(7) As
String
cArr(1) = "语文"
cArr(2) = "数学"
cArr(3) = "英语"
cArr(4) = "物理"
cArr(5) = "化学"
cArr(6) = "政治"
cArr(7) = "历史"
'cArr(8) = "物理"
'cArr(9) = "化学"
'创建空表并命名
For kemu = 1 To 7
Worksheets.Add
after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = cArr(kemu)
End With
Next kemu
'给空表赋值
For kemu = 1 To 7
s = 1
For bj = 1 To 6
With Sheets(cArr(kemu))
.Columns(s).Value = Sheets(bj &
"班").Columns(2).Value
.Columns(s + 1).Value = Sheets(bj &
"班").Columns(kemu + 2).Value
'.Columns(s + 2).Value = Sheets(bj &
"班").Columns(kemu + 8).Value
End With
s = s + 3
Next bj
Next kemu
'以下排序、设置列宽、对齐
'num =
ActiveSheet.[b65536].End(xlUp).Row
num =
ActiveSheet.UsedRange.Rows.Count
For kemu = 1 To 7
Worksheets(cArr(kemu)).Activate
For ii = 0 To 5
Columns(1).Offset(, 3 *
ii).ColumnWidth = 7.5
Columns(2).Offset(, 3 *
ii).ColumnWidth = 3.8
Columns(3).Offset(, 3 *
ii).ColumnWidth = 2
With Range("a1:b" &
num).Offset(, 3 * ii)
.Sort
key1:=Range("b1").Offset(, 3 * ii), Order1:=xlDescending,
Header:=xlYes
.HorizontalAlignment =
xlCenter
.VerticalAlignment =
xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
Next ii
Next kemu
End Sub
加载中…
(2014-05-27 12:38:23)