Excel宏应用实例

Sub 动态及格优秀率统计()
Dim nCount As Integer
Dim jg As Integer
Dim yx As Integer
Dim curval As Single
Dim jgxs As Single
Dim yxxs As Single
Dim name As String
Dim st(8, 3)
Dim result(8)
Dim a(600, 3)
Dim sort(8, 60, 2)
Dim bjrs(8)

Sheets("成绩统计").Select
jgxs = ActiveSheet.Cells(2, 3)
yxxs = ActiveSheet.Cells(2, 6)



nCount = 1
bjrs(1) = 1
bjrs(2) = 1
bjrs(3) = 1
Sheets("学生成绩测试1").Select
name = Left(ActiveSheet.Cells(2, 1), 1)
For j = 4 To 29
If ActiveSheet.Cells(j, 2) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "1班"
a(nCount, 2) = ActiveSheet.Cells(j, 1)
a(nCount, 3) = ActiveSheet.Cells(j, 2)

bjrs(1) = bjrs(1) + 1
sort(1, bjrs(1), 1) = ActiveSheet.Cells(j, 1)
sort(1, bjrs(1), 2) = ActiveSheet.Cells(j, 2)
End If

If ActiveSheet.Cells(j, 4) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "1班"
a(nCount, 2) = ActiveSheet.Cells(j, 3)
a(nCount, 3) = ActiveSheet.Cells(j, 4)


bjrs(1) = bjrs(1) + 1
sort(1, bjrs(1), 1) = ActiveSheet.Cells(j, 3)
sort(1, bjrs(1), 2) = ActiveSheet.Cells(j, 4)
End If


If ActiveSheet.Cells(j, 6) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "2班"
a(nCount, 2) = ActiveSheet.Cells(j, 5)
a(nCount, 3) = ActiveSheet.Cells(j, 6)

bjrs(2) = bjrs(2) + 1
sort(2, bjrs(2), 1) = ActiveSheet.Cells(j, 5)
sort(2, bjrs(2), 2) = ActiveSheet.Cells(j, 6)
End If

If ActiveSheet.Cells(j, 8) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "2班"
a(nCount, 2) = ActiveSheet.Cells(j, 7)
a(nCount, 3) = ActiveSheet.Cells(j, 8)
bjrs(2) = bjrs(2) + 1
sort(2, bjrs(2), 1) = ActiveSheet.Cells(j, 7)
sort(2, bjrs(2), 2) = ActiveSheet.Cells(j, 8)
End If


If ActiveSheet.Cells(j, 10) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "3班"
a(nCount, 2) = ActiveSheet.Cells(j, 9)
a(nCount, 3) = ActiveSheet.Cells(j, 10)
bjrs(3) = bjrs(3) + 1
sort(3, bjrs(3), 1) = ActiveSheet.Cells(j, 9)
sort(3, bjrs(3), 2) = ActiveSheet.Cells(j, 10)
End If

If ActiveSheet.Cells(j, 12) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "3班"
a(nCount, 2) = ActiveSheet.Cells(j, 11)
a(nCount, 3) = ActiveSheet.Cells(j, 12)
bjrs(3) = bjrs(3) + 1
sort(3, bjrs(3), 1) = ActiveSheet.Cells(j, 11)
sort(3, bjrs(3), 2) = ActiveSheet.Cells(j, 12)
End If
Next j

Sheets("学生成绩测试2").Select

bjrs(4) = 1
bjrs(5) = 1
bjrs(6) = 1
For j = 4 To 29
If ActiveSheet.Cells(j, 2) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "4班"
a(nCount, 2) = ActiveSheet.Cells(j, 1)
a(nCount, 3) = ActiveSheet.Cells(j, 2)
bjrs(4) = bjrs(4) + 1
sort(4, bjrs(4), 1) = ActiveSheet.Cells(j, 1)
sort(4, bjrs(4), 2) = ActiveSheet.Cells(j, 2)
End If

If ActiveSheet.Cells(j, 4) <> "" Then
nCount =

nCount + 1
a(nCount, 1) = "4班"
a(nCount, 2) = ActiveSheet.Cells(j, 3)
a(nCount, 3) = ActiveSheet.Cells(j, 4)
bjrs(4) = bjrs(4) + 1
sort(4, bjrs(4), 1) = ActiveSheet.Cells(j, 3)
sort(4, bjrs(4), 2) = ActiveSheet.Cells(j, 4)
End If

If ActiveSheet.Cells(j, 6) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "5班"
a(nCount, 2) = ActiveSheet.Cells(j, 5)
a(nCount, 3) = ActiveSheet.Cells(j, 6)
bjrs(5) = bjrs(5) + 1
sort(5, bjrs(5), 1) = ActiveSheet.Cells(j, 5)
sort(5, bjrs(5), 2) = ActiveSheet.Cells(j, 6)
End If

If ActiveSheet.Cells(j, 8) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "5班"
a(nCount, 2) = ActiveSheet.Cells(j, 7)
a(nCount, 3) = ActiveSheet.Cells(j, 8)
bjrs(5) = bjrs(5) + 1
sort(5, bjrs(5), 1) = ActiveSheet.Cells(j, 7)
sort(5, bjrs(5), 2) = ActiveSheet.Cells(j, 8)
End If


If ActiveSheet.Cells(j, 10) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "6班"
a(nCount, 2) = ActiveSheet.Cells(j, 9)
a(nCount, 3) = ActiveSheet.Cells(j, 10)
bjrs(6) = bjrs(6) + 1
sort(6, bjrs(6), 1) = ActiveSheet.Cells(j, 9)
sort(6, bjrs(6), 2) = ActiveSheet.Cells(j, 10)
End If

If ActiveSheet.Cells(j, 12) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "6班"
a(nCount, 2) = ActiveSheet.Cells(j, 11)
a(nCount, 3) = ActiveSheet.Cells(j, 12)
bjrs(6) = bjrs(6) + 1
sort(6, bjrs(6), 1) = ActiveSheet.Cells(j, 11)
sort(6, bjrs(6), 2) = ActiveSheet.Cells(j, 12)
End If
Next j

Sheets("学生成绩测试3").Select

bjrs(7) = 1
bjrs(8) = 1
For j = 4 To 29
If ActiveSheet.Cells(j, 2) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "7班"
a(nCount, 2) = ActiveSheet.Cells(j, 1)
a(nCount, 3) = ActiveSheet.Cells(j, 2)
bjrs(7) = bjrs(7) + 1
sort(7, bjrs(7), 1) = ActiveSheet.Cells(j, 1)
sort(7, bjrs(7), 2) = ActiveSheet.Cells(j, 2)
End If

If ActiveSheet.Cells(j, 4) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "7班"
a(nCount, 2) = ActiveSheet.Cells(j, 3)
a(nCount, 3) = ActiveSheet.Cells(j, 4)
bjrs(7) = bjrs(7) + 1
sort(7, bjrs(7), 1) = ActiveSheet.Cells(j, 3)
sort(7, bjrs(7), 2) = ActiveSheet.Cells(j, 4)
End If



If ActiveSheet.Cells(j, 6) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "8班"
a(nCount, 2) = ActiveSheet.Cells(j, 5)
a(nCount, 3) = ActiveSheet.Cells(j, 6)
bjrs(8) = bjrs(8) + 1
sort(8, bjrs(8), 1) = ActiveSheet.Cells(j, 5)
sort(8, bjrs(8), 2) = ActiveSheet.Cells(j, 6)
End If

If ActiveSheet.Cells(j, 8) <> "" Then
nCount = nCount + 1
a(nCount, 1) = "8班"
a(nCount, 2) = ActiveSheet.Cells(j, 7)
a(nCount, 3) = ActiveSheet.Cells(j, 8)
bjrs(8) = bjrs(8) + 1
sort(8, bjrs(8), 1) = ActiveSheet.Cells(j, 7)
sort(8, bjrs(8), 2) = ActiveSheet.Cells(j, 8)
End If


Next j

For m = 1 To 8

Sheets.Add after:=Sheets(Sheets.Count)
https://www.360docs.net/doc/6110888075.html, = "排序"
ActiveSheet.Cells(1, 1) = "姓名"
ActiveSheet.Cells(1, 2) = "成绩"

For i = 2 To bjrs(m)
ActiveSheet.Cells(i, 1) = sort(m, i, 1)
ActiveSheet.Cells(i, 2) = sort(m, i, 2)

Next i

Selection.sort Key1:=Range("b2"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal

For i = 2 To bjrs(m)
sort(m, i, 1) = ActiveSheet.Cells(i, 1)
sort(m, i, 2) = ActiveSheet.Cells(i, 2)

Next i

If m < 4 Then
Sheets("学生成绩测试1").Select
For i = 4 To 29
ActiveSheet.Cells(i, 4 * (m - 1) + 1) = ""
ActiveSheet.Cells(i, 4 * (m - 1) + 2) = ""
ActiveSheet.Cells(i, 4 * (m - 1) + 3) = ""
ActiveSheet.Cells(i, 4 * (m - 1) + 4) = ""
Next i
For i = 2 To bjrs(m)
If i < 25 Then
ActiveSheet.Cells(i + 2, 4 * (m - 1) + 1) = sort(m, i, 1)
ActiveSheet.Cells(i + 2, 4 * (m - 1) + 2) = sort(m, i, 2)
End If
If i > 24 Then
ActiveSheet.Cells(i - 21, 4 * (m - 1) + 3) = sort(m, i, 1)
ActiveSheet.Cells(i - 21, 4 * (m - 1) + 4) = sort(m, i, 2)
End If
Next i
End If

If m < 7 And m > 3 Then
Sheets("学生成绩测试2").Select
For i = 4 To 29
ActiveSheet.Cells(i, 4 * (m - 4) + 1) = ""
ActiveSheet.Cells(i, 4 * (m - 4) + 2) = ""
ActiveSheet.Cells(i, 4 * (m - 4) + 3) = ""
ActiveSheet.Cells(i, 4 * (m - 4) + 4) = ""
Next i
For i = 2 To bjrs(m)
If i < 25 Then
ActiveSheet.Cells(i + 2, 4 * (m - 4) + 1) = sort(m, i, 1)
ActiveSheet.Cells(i + 2, 4 * (m - 4) + 2) = sort(m, i, 2)
End If
If i > 24 Then
ActiveSheet.Cells(i - 21, 4 * (m - 4) + 3) = sort(m, i, 1)
ActiveSheet.Cells(i - 21, 4 * (m - 4) + 4) = sort(m, i, 2)
End If
Next i
End If


If m > 6 Then
Sheets("学生成绩测试3").Select
For i = 4 To 29
ActiveSheet.Cells(i, 4 * (m - 7) + 1) = ""
ActiveSheet.Cells(i, 4 * (m - 7) + 2) = ""
ActiveSheet.Cells(i, 4 * (m - 7) + 3) = ""
ActiveSheet.Cells(i, 4 * (m - 7) + 4) = ""
Next i
For i = 2 To bjrs(m)
If i < 25 Then
ActiveSheet.Cells(i + 2, 4 * (m - 7) + 1) = sort(m, i, 1)
ActiveSheet.Cells(i + 2, 4 * (m - 7) + 2) = sort(m, i, 2)
End If
If i > 24 Then
ActiveSheet.Cells(i - 21, 4 * (m - 7) + 3) = sort(m, i, 1)
ActiveSheet.Cells(i - 21, 4 * (m - 7) + 4) = sort(m, i, 2)
End If
Next i
End If
Application.DisplayAlerts = False
Sheets("排序").Select
ActiveWindow.SelectedSheets.Delete
Next m

If nCount > 1 Then
Sheets.Add after:=Sheets(Sheets.Count)
https://www.360docs.net/doc/6110888075.html, = "成绩排名"


ActiveSheet.Cells(1, 1) = "班级"
ActiveSheet.Cells(1, 2) = "姓名"
ActiveSheet.Cells(1, 3) = "成绩"

For i = 2 To nCount
ActiveSheet.Cells(i, 1) = a(i, 1)

ActiveSheet.Cells(i, 2) = a(i, 2)
ActiveSheet.Cells(i, 3) = a(i, 3)
Next i

Range("A2:C600").Select

Selection.sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal

st(1, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "1班")
st(2, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "2班")
st(3, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "3班")
st(4, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "4班")
st(5, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "5班")
st(6, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "6班")
st(7, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "7班")
st(8, 1) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "8班")

If jgxs <= 0 Then
jg = (nCount - 1) * 0.8
Else
jg = (nCount - 1) * jgxs
End If


Sheets("成绩排名").Select
Sheets("成绩排名").Copy after:=Sheets("成绩排名")
Sheets("成绩排名 (2)").Select
Sheets("成绩排名 (2)").name = "及格人员"

If nCount = 2 Or nCount = 3 Then
curval = ActiveSheet.Cells(2, 3)
Else
curval = ActiveSheet.Cells(nCount - jg, 3)
End If


For i = 2 To nCount - jg + 2
If ActiveSheet.Cells(2, 3) < curval Then
Sheets("及格人员").Range("2:2").Delete
End If
Next i


st(1, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "1班")
st(2, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "2班")
st(3, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "3班")
st(4, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "4班")
st(5, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "5班")
st(6, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "6班")
st(7, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "7班")
st(8, 2) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "8班")
If yxxs <= 0 Then
yx = (nCount - 1) * 0.25
Else
yx = (nCount - 1) * yxxs
End If

Sheets("成绩排名").Select
Sheets("成绩排名").Copy after:=Sheets("及格人员")
Sheets("成绩排名 (2)").Select
Sheets("成绩排名 (2)").name = "优秀人员"
If nCount = 1 Then
curval = ActiveSheet.Cells(2, 3)
Else
curval = ActiveSheet.Cells(nCount - yx + 1, 3)
End If
For i = 2 To nCount - yx + 2
If ActiveSheet.Cells(2, 3) < curval Then
Sheets("优秀人员").Range("2:2").Delete
End If
Next i


st(1, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "1班")
st(2, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "2班")
st(3, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "3班")
st(4, 3) = Application.Workshe

etFunction.CountIf(Range("A2:A600"), "4班")
st(5, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "5班")
st(6, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "6班")
st(7, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "7班")
st(8, 3) = Application.WorksheetFunction.CountIf(Range("A2:A600"), "8班")

Sheets("成绩统计").Select


curval = Len(ActiveSheet.Cells(1, 1)) - 1
ActiveSheet.Cells(1, 1) = name & Right(ActiveSheet.Cells(1, 1), curval)

For i = 4 To 11
ActiveSheet.Cells(i, 2) = ""
ActiveSheet.Cells(i, 3) = ""
ActiveSheet.Cells(i, 4) = ""
ActiveSheet.Cells(i, 5) = ""
ActiveSheet.Cells(i, 6) = ""
Next i


For i = 1 To 8
ActiveSheet.Cells(i + 3, 2) = st(i, 1)
ActiveSheet.Cells(i + 3, 3) = st(i, 2)
ActiveSheet.Cells(i + 3, 5) = st(i, 3)
If st(i, 1) > 0 Then
ActiveSheet.Cells(i + 3, 4) = st(i, 2) / st(i, 1)
ActiveSheet.Cells(i + 3, 6) = st(i, 3) / st(i, 1)
Else
ActiveSheet.Cells(i + 3, 2) = ""
ActiveSheet.Cells(i + 3, 3) = ""
ActiveSheet.Cells(i + 3, 5) = ""
End If
Next i


Range("A3:F3").Select
Selection.Font.Bold = True '加粗
Range("A1:F12").Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous

Application.DisplayAlerts = False
Sheets("成绩排名").Select
ActiveWindow.SelectedSheets.Delete
Sheets("及格人员").Select
ActiveWindow.SelectedSheets.Delete
Sheets("优秀人员").Select
ActiveWindow.SelectedSheets.Delete
End If

End Sub