マークシートの採点で指示に従わずに同じ答えをした場合は０点にしたい。

ExcelのVBAを使ってマークシートの採点をしています。

英語の試験です。環境はExcel2016, Windows10です。

「問題番号(1)～(4)に入るのに適切な語をそれぞれ１つ選び、番号で答えなさい。ただし同じものを繰り返し使ってはいけません。」というような問題の採点方法を考えています。

例えば選択肢は1.at　2.in　3.for　4.withとし、正解は(1)は4,(2)は1,(3)は2,(4)は3だとします。

何も考えずに最低１問だけでも正解しようとする生徒はすべてを1と答えます。

もしくは(1),(2)をどちらも1,(3),(4)をどちらも3というように答える生徒もいます。

センター試験等の採点がどうなっているかはわからないのですが、生徒に何も考えずに答えることをやめさせたいので、同じ答えを２回以上答えた場合は、正解であってもどちらも不正解にしたいと考えています。

上記の例で言えば、すべて1と答えた生徒も、(1),(2)をどちらも1,(3),(4)をどちらも3と答えた生徒も0点となるように採点したいのです。

他の部分の採点をVBAでしていますので、この部分だけを関数で採点というわけにはいきません。

VBAで採点するとしたらどのような方法があるか教えていただけないでしょうか？

よろしくお願いいたします。m(__)m

質問者からの補足コメント

• 画像を参照して下さい。

  
    補足日時：2018/12/29 10:32

No.5 ベストアンサー 回答者： WindFaller 回答日時： 2018/12/30 01:50

ちょっと読んでみましたが、No.4さんのご指摘の通り、組み込み型でないといけないようですね。

まあ、Mode.Mult は、どうやら、昔の　Mode（頻度)でも済みそうなのですが……

後出しですから、同じようなスタイルではダメだと思い作りました。
後発の工夫は、数字の解答ではなく、文字(a,b,c, ア,イ,ウ または混在)の解答でもチェックしてくれます。
ロジックは、一つのセルの単語を全部合わせた文字列から削除すると、いくつ残るかという方法です。一つのセルの単語以上に消えたら、重複しているということです。区切り文字は、;(単語); にしました。

これを他のマクロに取り入れてくれればよいです。

'//標準モジュール
Private Function IsDouble(Rng As Range) As Boolean
　'' 引数は、範囲
　Dim a, b, c
　Dim sChain As String
　Dim i As Long, j As Long 'カウンター
　Dim num As Long '引数の数
　num = Rng.Cells.Count
　j = 1
　For j = 1 To num
　　sChain = sChain & ";" & Trim(Rng.Cells(j).Value) & ";" '連結文字を作る
　Next j
　For i = 1 To num
　　a = Len(sChain)
　　c = ";" & Rng.Cells(i).Value & ";"
　　If Len(c) > 2 Then
　　　b = Len(Replace(sChain, c, "")) '連結文字から文字を抜いた文字数
　　　If (a - b) > Len(c) Then '一単語の長さよりも文字数が少なければ重複あり
　　　　IsDouble = True　'見つけたら、そのあとは離脱
　　　　Exit Function
　　　End If
　　End If
　Next i
End Function


取り付けた例
Sub CheckAnswer()
Dim r As Range
　For Each r In Range("C3", Cells(Rows.Count, 3).End(xlUp))
　 If IsDouble(r.Resize(, 4)) Then　　'←ユーザー定義関数を取り付ける
　　r.Offset(, 4).Value = "×"
　 Else
　　r.Offset(, 4).Value = ""　'●
　 End If
　Next r
End Sub

実際は、重複チェッカー以外にも、配点のチェッカーが働くわけで、●側に配点する部分がなされることになるでしょう。

この回答へのお礼

忙しい中、回答ありがとうございます。

お示しいただいたコードを解読するのに時間がかかってしまいました。m(__)m

私の理解が正しければ、私の場合だと以下のような考えでいいでしょうか？

1.選択しているものをすべて文字として連結する。例えば、正解の場合は順番に「;4;;1;;2;;3;」の12文字となる。
2.この12文字から選択した文字をReplaceで消すし、残った文字数(選択していないものの文字数)をカウントする。
　重複していなければ9文字になるが、重複していれば6文字または3文字または0文字になる。
3.すべての選択肢の文字数の12から選択していないものの文字数(9文字または6文字または3文字または0文字)を引く。
4.重複していなければ12-9=3となり、選択したものの文字数と等しくなる(選択したものの文字数より大きくはならない)。
5.重複していれば12-6=6または12-3=9または12-0=12となり、いずれも選択したものの文字数の3より大きくなる。

なんかこうなるとVBAの知識もないと無理ですが、それ以上にこのような発想ができることが驚きです。

私１人で考えていたら一生思いつかないような方法です。なんか変な言い方ですが、感動しました。m(__)m

お礼日時：2018/12/31 17:24

No.6 回答者： WindFaller 回答日時： 2019/01/01 02:17

No.5の回答者です。

>私の場合だと以下のような考えでいいでしょうか？
理解していただいたとおりです。

最初、4,1,1,3 と書いて、1 を消せば、2文字減るからと考えたのですが、必ずしもそうではないのは、1,12,13,14 となったら、4文字消えてしまうわけで、;1; と余分な文字を入れて、重複しているか調べました。　No.5 で書いたように、a,b,c の文字の答えがあるから、文字列の可能なように考えました。

>このような発想ができることが驚きです。
このようなコードのスタイルは、時々、VBAでは出てきます。
他に、いろいろ考えてみたけれども、数字と文字の混在で可能性のあるものは、今の所、これしか見つからなかったのです。数字なら関数の方法はあります。Mode_Mult（Mode) は、数字なら可能なだけでなく、配列が可能なのでコンパクトにできるメリットがあります。それに比べて、CountIf関数 やSmall 関数も考えましたが、今ひとつなのでした。

このあとのことを考えてしまいました。一体、どのようにして採点をするか、いえ、そもそも、
表に自動取り込みならよいのですが、手動でいれるのも大変かなって思いました。

　 If IsDouble(r.Resize(, 4)) Then　　'←ユーザー定義関数を取り付ける
　　r.Offset(, 4).Value = "×"
　 Else
　　r.Offset(, 4).Value = ""　'●　　←こちらは、本来は、採点が出てくるわけですよね。このままではいけないでしょうけれども……。
　 End If

この回答へのお礼

再度の回答ありがとうございます。

＞このようなコードのスタイルは、時々、VBAでは出てきます。
そうなのですか。私は初めて目にしたのですが、最初に考えた人はすごいですね。

でもそれをうまくここで利用するような回答していただき助かりました。

正月休みを利用して、マークシートのVBAに組み込むことができました。

ほんとうにありがとうございました。m(__)m

お礼日時：2019/01/04 09:18

No.4 回答者： ママチャリ 回答日時： 2018/12/29 15:18

「他の部分の採点をVBAでしています」ということなので、重複の考慮が無い場合の採点は出来ているのですよね？既存のロジックに合わせないと意味がなさそうなので、重複の判定方法だけをコーディングしてみました。

こんな感じです。

Sub saiten()
Dim a As Variant
a = Application.Mode_Mult(Range("C3:F3"))
If TypeName(a) <> "Error" Then
MsgBox "0点"
Else
MsgBox "採点"
End If
End Sub

この回答へのお礼

回答ありがとうございます。

この方法だと重複しているか否かがわかるだけでしょうか？

Application.Mode_Multについてググってみたのですが、詳しい解説のあるサイトを見つけることができませんでしたので、よくわかりませんでした。

もう少し、調べてみます。

お礼日時：2018/12/29 16:34

No.3 回答者： tatsu99 回答日時： 2018/12/29 14:49

以下のマクロを標準モジュールに登録してください。

力ずくなので大量の行の場合は、遅くなるかも知れません。
列が増えた場合（4問から5問に変更など）は考慮していません。
シート名はSheet1としています。
同一の番号があった場合は、無条件に得点なしとしています。
-----------------------------------------------------
Option Explicit
Public Sub 採点()
Dim ws As Worksheet
Dim maxrow As Long
Dim row1 As Long
Dim col1 As Long
Dim val As Variant
Dim point As Long
Set ws = Worksheets("Sheet1")
maxrow = ws.Cells(Rows.Count, 1).End(xlUp).Row 'sheet1 最終行を求める
For row1 = 3 To maxrow
point = 0
For col1 = 3 To 6
val = ws.Cells(row1, col1).Value
If IsDuplicate(ws, row1, col1, val) = False Then
If val = ws.Cells(1, col1).Value Then
point = point + 1
End If
End If
Next
ws.Cells(row1, 7).Value = point
Next
MsgBox ("完了")
End Sub

'重複チェック
Private Function IsDuplicate(ByVal ws As Worksheet, ByVal prow As Long, ByVal pcol As Long, ByVal pval As Variant)
Dim col As Long
IsDuplicate = True
For col = 3 To 6
If col <> pcol And pval = ws.Cells(prow, col).Value Then
Exit Function
End If
Next
IsDuplicate = False
End Function

この回答へのお礼

回答ありがとうございます。

ちょっと読み解くのに時間がかかりそうですが、頑張って調べてみます。

お礼日時：2018/12/29 16:31

No.2 回答者： bathbadya 回答日時： 2018/12/29 14:11

セルCとDを比較して、同じならフラッグを立てる。

同様に、セルCとE、CとF、DとE…
フラッグが立っていたら、定数を０とする。
得点と先の定数を掛け算して、最終得点を得る。

この回答へのお礼

回答ありがとうございます。

CollectionオブジェクトやDictionaryオブジェクトとか使うのかなと考えていました。

すなおにひとつずつ比較するほうが簡単そうですね。

お礼日時：2018/12/29 14:21

No.1 回答者： fakeflake 回答日時： 2018/12/29 12:16

それをするには減点する変数を作り、自セルと右隣のセルとを比較して同じであればその変数を-1します。

一番右にあるセルのみ、左隣と比較します。で、最後に得点の合計と減点する変数を足したものを総得点とします。ゼロ未満は0点です。

なんですけど、その「同じ番号が連続したら得点にしない」という判定方法には賛成できません。また同じ番号が連続しない前提だと、試験が簡単になってしまうおそれがあります。

と言うのは、この例のように設問4つで回答番号が全て重複しないなら、1つ正解が解っていれば残りの問題は3択になるし、2つ解っていれば2択に、3つ解ってると最後の一つは知らなくても自然に正解が取れますよね。それでいいんでしょうかってことです。

それにまじめに考えた結果が1111や1133だった場合、それをはじいてしまうのは乱暴過ぎと思うし、もっと設問数が多い試験で延々と12341234と答えることも十分ふざけてるけど、今の考え方では検出できません。

この回答へのお礼

回答ありがとうございます。

「同じ答えを２回以上答えた場合は、正解であってもどちらも不正解にしたい」のであって、「同じ番号が連続したら得点にしない」のではありません。

隣に同じ番号があれば０点にするのならそれほど難しくはないですね。

問題と答えを１対１対応になるように作成しているのに全部外すよりはましという考えで同じ答えを答える生徒に対応するためです。ですのでまじめに考えた結果が1111や1133になることはありません。

12341234と答えたらすべてを不正解になる可能性がありますが、今回の場合はこのような処理をしなければ考えなくても０点になることはありません。

要は生徒にきちんと考えて解答してほしいだけなんです。ただこうでもしないと考えようともしない生徒が多いので。(*_*;

お礼日時：2018/12/29 12:39