Question

excel电子表格 宏 高手请进，高分追加

有如下结构的一个表格，3个主要字段是：姓名、考试类型、分数，
考试类型有A、B、C、D 四种。各种考生记录混在一起，我想通过一个宏分别求出：
1、参加不同类型考试的考生，平均分各是多少？
2、参加不同类型考试的考生，最高分和最低分各是多少？(最低分是除0分外的最低分)
3、参加不同类型考试的考生，得最高分和最低分的分别有多少人？
4、参加不同类型考试的考生，考试分数的方差是多少？(var函数是方差函数)

也就是说对考ABCD 4个类型的考生，分别计算上面4种数值。至于结果可以输出到另一个电子表格文件里。
本人水平有限，这题有点麻烦，请高手详细指点。成功后另有100分追加

Answer 1

Sub 分类汇总()

'对sheet1的A:C列进行分类统计汇总，结果放在sheet2的A1:E7

Dim s1 As Worksheet: Set s1 = Worksheets("sheet1") '原数据表
Dim s2 As Worksheet: Set s2 = Worksheets("sheet2") '新数据表
Dim r(1 To 5) As Integer: r(5) = s1.[A65536].End(xlUp).Row '原数据表行数，以A列为准

s2.Cells.Delete: s1.Range("A1:C" & r(5)).Copy s2.Range("A1")
s2.Range("A1:C" & r(5)).Sort Key1:=s2.Range("B2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlSortColumns, SortMethod:=xlPinYin, DataOption1:=xlSortNormal
s2.Range("f1:i1") = Array("A", "B", "C", "D")
s2.Range("e2:e7") = Application.WorksheetFunction.Transpose(Array( _
"平均分", "最高分", "大于0的最低分", "最高分人数", "最低分人数", "分数方差"))

For i = 1 To 4
r(i) = s2.Range("B:B").Find( _
WHAT:=s2.Cells(1, i + 5), LookIn:=xlValues, LookAt:=xlWhole).Row
Next
r(5) = r(5) + 1

Dim rng(1 To 4) As Range '分类区域
For i = 1 To 4
Set rng(i) = s2.Cells(r(i), 3).Resize(r(i + 1) - r(i), 1)
Next

Dim rs(1 To 6, 1 To 4) '结果
For i = 1 To 4
rs(1, i) = Application.WorksheetFunction.Average(rng(i)) '平均分
rs(2, i) = Application.WorksheetFunction.Max(rng(i)) '最高分
j = 1
Do
temp = Application.WorksheetFunction.Small(rng(i), j): j = j + 1
Loop Until (j > rng(i).Rows.Count) Or (temp > 0)
rs(3, i) = temp '最低分
rs(4, i) = Application.WorksheetFunction.CountIf(rng(i), rs(2, i)) '最高分人数
rs(5, i) = Application.WorksheetFunction.CountIf(rng(i), rs(3, i)) '最低分人数
rs(6, i) = Application.WorksheetFunction.Var(rng(i)) '分数方差
Next
s2.Range("F2").Resize(6, 4) = rs
s2.Range("F2:i2", "f7:i7").NumberFormatLocal = "0.00_ "
s2.Range("F3:i6").NumberFormatLocal = "G/通用格式"
s2.Range("a:d").Delete
s2.Cells.EntireColumn.AutoFit
s2.Cells.EntireRow.AutoFit
s2.Cells.HorizontalAlignment = xlCenter
s2.Activate
End Sub
-----------
原数据表 sheet1
新数据表 sheet2

打开原数据表，在表名上点右键，选“查看代码”，打开代码窗口，将上面的代码复制入其中，并根据实际情况，将代码内的表名改为实际表名（有注释）然后，按 F5 键运行程序
-----------------
其他关于结果的格式等问题，请Hi我，或留消息，详细解答

Answer 2

Sub Macro1()

Dim ARow As Integer
Sheets("sheet1").Select
Columns("C:C").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
ARow = ActiveCell.Row - 1

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R" & ARow & "C3").CreatePivotTable TableDestination:="", TableName:= _
"数据透视表1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(1, 1)
ActiveSheet.Cells(1, 1).Select
ActiveSheet.PivotTables("数据透视表1").AddFields RowFields:="考试类型"
With ActiveSheet.PivotTables("数据透视表1").PivotFields("分数")
.Orientation = xlDataField
.Caption = "最大值项:分数"
.Position = 1
.Function = xlMax
End With
With ActiveSheet.PivotTables("数据透视表1").PivotFields("分数")
.Orientation = xlDataField
.Caption = "最小值项:分数"
.Position = 2
.Function = xlMin
End With
With ActiveSheet.PivotTables("数据透视表1").PivotFields("分数")
.Orientation = xlDataField
.Caption = "平均值项:分数"
.Position = 3
.Function = xlAverage
End With
With ActiveSheet.PivotTables("数据透视表1").PivotFields("分数")
.Orientation = xlDataField
.Caption = "方差项:分数"
.Function = xlVar
End With
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Name = "统计"

Dim CountX(4, 2) As Single
For i = 1 To 4
CountX(i, 1) = Cells(2 + (i - 1) * 4, 3)
CountX(i, 2) = Cells(3 + (i - 1) * 4, 3)

Next i
Dim MAXMIN(4, 2) As Single

Sheets("sheet1").Select
For j = 2 To ARow
Select Case Cells(j, 2).Text
Case "A"
If Cells(j, 3).Value = CountX(1, 1) Then
MAXMIN(1, 1) = MAXMIN(1, 1) + 1
ElseIf Cells(j, 3).Value = CountX(1, 2) Then
MAXMIN(1, 2) = MAXMIN(1, 2) + 1
End If
Case "B"
If Cells(j, 3).Value = CountX(2, 1) Then
MAXMIN(2, 1) = MAXMIN(2, 1) + 1
ElseIf Cells(j, 3).Value = CountX(2, 2) Then
MAXMIN(2, 2) = MAXMIN(2, 2) + 1
End If
Case "C"
If Cells(j, 3).Value = CountX(3, 1) Then
MAXMIN(3, 1) = MAXMIN(3, 1) + 1
ElseIf Cells(j, 3).Value = CountX(3, 2) Then
MAXMIN(3, 2) = MAXMIN(3, 2) + 1
End If
Case "D"
If Cells(j, 3).Value = CountX(4, 1) Then
MAXMIN(4, 1) = MAXMIN(4, 1) + 1
ElseIf Cells(j, 3).Value = CountX(4, 2) Then
MAXMIN(4, 2) = MAXMIN(4, 2) + 1
End If
End Select
Next j

Sheets("统计").Select
For i = 1 To 4
Cells(2 + (i - 1) * 4, 4) = MAXMIN(i, 1)
Cells(3 + (i - 1) * 4, 4) = MAXMIN(i, 2)

Next i
Range("D1").Value = "最大最小值数"
End Sub