VBA技巧精粹020-如何统计选择题所有可能选项所占百分比（含正答率）

Option Base 1

'此为对字串进行分列处理，将每个学生的每个小题的选项进行分列。
Sub 分列操作()

Dim i As Integer, totalR As Integer, j As Integer

totalR = Range("A65536").End(xlUp).Row

For i = 2 To totalR

For j = 1 To Len(Cells(i, 5).Value)

Cells(i, 5).Offset(0, j).Value = Mid(Cells(i, 5).Value, j, 1)

Next j

Next i

End Sub
'若每个小题为不定项，则需根据阅卡机的规则对选项进行转化

Sub 转化操作()

Dim i As Integer, totalR As Integer, j As Integer, Rng As Range, totalC As Integer

totalR = Range("A65536").End(xlUp).Row

totalC = Range("IV2").End(xlToLeft).Column

For Each Rng In Range(Cells(2, 6), Cells(totalR, totalC))

Select Case Rng.Value

Case "F"

Rng.Value = "BC"

Case "G"

Rng.Value = "ABC"

Case "H"

Rng.Value = "AB"

Case "I"

Rng.Value = "AD"

Case "J"

Rng.Value = "BD"

Case "K"

Rng.Value = "ABD"

Case "L"

Rng.Value = "CD"

Case "M"

Rng.Value = "ACD"

Case "N"

Rng.Value = "BCD"

Case "O"

Rng.Value = "ABCD"

Case "P"

Rng.Value = "AC"

End Select

Next Rng

End Sub

'自此为进行百分比统计

Sub 统计各类选项所占百分比()

Dim R As Integer, tj As Double, Rng As Range, m As Integer, bz As String

Dim i As Integer, totalR As Integer, k As Integer, cs As Integer

Dim th As Integer, xx() As String, rs(40) As Integer

For th = 1 To 11 '此为选择题的实际题量，根据实际情况进行修改

Worksheets("sheet1").Copy Before:=Worksheets("sheet1")

ActiveSheet.Name = Trim(Str(th)) & "选项"

R = Range("B65536").End(xlUp).Row

For i = R To 1 Step -1

If Application.WorksheetFunction.CountIf(Range(Cells(1, th + 5), Cells(R, th + 5)), Cells(i, th + 5)) > 1 Then

Range(Cells(i, 2), Cells(i, 2)).EntireRow.Delete

End If

Next i

R = Range("A65536").End(xlUp).Row

ReDim xx(R - 1)

For i = 1 To R - 1

xx(i) = Cells(i + 1, th + 5).Value

Next i

Application.DisplayAlerts = False

Worksheets(Trim(Str(th)) & "选项").Delete

Application.DisplayAlerts = True

Worksheets.Add

ActiveSheet.Name = Trim(Str(th)) & "题统计数据"

For cs = 1 To R - 1

Worksheets(Trim(Str(th)) & "题统计数据").Cells(1, Worksheets(Trim(Str(th)) & "题统计数据").Range("IV1").End(xlToLeft).Column + 1).Value = xx(cs)

Next cs

Cells(1, 1).Value = "班级"

For i = 1 To 38 '此处为班级数，根据实际情况进行修改。

Cells(i + 1, 1).Value = i

Next i

Worksheets("sheet1").Activate

totalR = Range("B65536").End(xlUp).Row

m = 0

For i = 1 To 38 '此处为班级数，根据实际情况进行修改。

rs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 2), Cells(totalR, 2)), Trim(Str(i)))

If rs(i) <> 0 Then

For cs = 1 To R - 1

For Each Rng In Range(Cells(2, th + 5), Cells(totalR, th + 5))

If Rng.Value = xx(cs) And Cells(Rng.Row, 2).Value = i Then

m = m + 1

End If

Next Rng

Worksheets(Trim(Str(th)) & "题统计数据").Cells(i + 1, cs + 1).Value = Format(m / rs(i), "0.00%")

m = 0

Next cs

End If

Next i

'重点突出正答率

bz = Worksheets("标准答案").Cells(th + 1, 1).Value

Worksheets(Trim(Str(th)) & "题统计数据").Activate

For Each Rng In Range(Cells(1, 2), Cells(1, Range("IV1").End(xlToLeft).Column))

If Rng.Value = bz Then

Rng.EntireColumn.Font.ColorIndex = 3

If Rng.Column <> 2 Then

Rng.EntireColumn.Cut

Columns("B:B").Select

Selection.Insert Shift:=xlToRight

End If

End If

Rng.Offset(0, 1).Select

Next Rng

Next th

End Sub