Scoring responses by macro

Hi All,

I’m requesting for some help on a macro that will enable me to score my responses.

In the attached:

Tab 1:

“Questions and Answers” has the sample responses collected. The respondent answers are given from Column C onwards
A brief explanation of the 3 logics that am requesting help with are also provided in Column H

Tab 2:

The correct answers per question are given in Column C of this Tab. These are to be used for evaluation of the responses received in Tab 1
All the incorrect responses from Tab 1 by question need to be counted and the counts to be reflected in Column D of this sheet

Look forward to your kind help. I have over 4000 responses on this, and will do such more tests every month.

Please let me know if anything needs further explanation.

Thanks a bunch!


Regards,
Spi

I'm sorry on this one. But really need a help here.

May I please request your kind assistance!

Once again sorry for this request. Normally, I'm very patient, but somehow have this due today so struggling to analyize it.

Deeply appreciate and value your kindest help!

May I with all humbleness request your assistance on this. Please help!

Try this code -

Option Explicit

Sub scoring()
Dim i As Long, j As Long, lcol As Long

Application.ScreenUpdating = False

With Worksheets("Questions and Answers")
    lcol = .Range("IV1").End(xlToLeft).Column
    For j = 3 To lcol
        For i = 2 To 26
            If .Cells(i, j).Value = Worksheets("Correct Answer").Range("C" & i).Value Then
                .Cells(27, j).Value = .Cells(27, j).Value + 1
            Else
                .Cells(28, j).Value = .Cells(28, j).Value + 1
                .Cells(i, j).Interior.Color = 255
                Worksheets("Correct Answer").Range("D" & i).Value = Worksheets("Correct Answer").Range("D" & i).Value + 1
            End If
        Next i
        .Cells(29, j).FormulaR1C1 = "=COUNTA(R[-26]C:R[-2]C)"
        .Cells(30, j).Value = .Cells(27, j) / .Cells(29, j)
        If .Cells(28, j).Value = "" Then .Cells(28, j).Value = "0"
        .Cells(30, j).NumberFormat = "0%"
    Next j
End With

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

Clear out the calculations in rows 27:30 and in the sheet ("Correct Answers") column D before running it.

Copy the Excel VBA code
Select the workbook in which you want to store the Excel VBA code
Hold the Alt key, and press the F11 key, to open the Visual Basic Editor
Choose Insert | Module
Where the cursor is flashing, choose Edit | Paste

To run the Excel VBA code:
Choose View | Macros
Select a macro in the list, and click the Run button

Thank you Arlu.

You made my day. I'll run it right way and seek any further inputs if required.

Really really appreciate your kind assistance

Thank you Arlu!

My report went well. Your VBA worked like a charm. I think I'll need 1 addition though, but let me be completely sure how it is needed.

I am going ahead and closing the thread.

Do I have your permission to post that addition? For today, I did it manually which took me quite a bit of time. I'll do as you suggest.

Great help, thanks!

Sure, what addition?

Sorry for the late reply.

My request on the last bit is to be able to add data of the incorrect responses in the "Summary" tab. I've attached a sample...You'll notice that the 3rd tab has output am requesting help on.

If a snippet could be added to the code below to facilitate this it would be great....thank you!

Option Explicit

Sub scoring()
Dim i As Long, j As Long, lcol As Long

Application.ScreenUpdating = False

With Worksheets("Questions and Answers")
    lcol = .Range("IV1").End(xlToLeft).Column
    For j = 3 To lcol
        For i = 2 To 26
            If .Cells(i, j).Value = Worksheets("Correct Answer").Range("C" & i).Value Then
                .Cells(27, j).Value = .Cells(27, j).Value + 1
            Else
                .Cells(28, j).Value = .Cells(28, j).Value + 1
                .Cells(i, j).Interior.Color = 255
                Worksheets("Correct Answer").Range("D" & i).Value = Worksheets("Correct Answer").Range("D" & i).Value + 1
            End If
        Next i
        .Cells(29, j).FormulaR1C1 = "=COUNTA(R[-26]C:R[-2]C)"
        .Cells(30, j).Value = .Cells(27, j) / .Cells(29, j)
        If .Cells(28, j).Value = "" Then .Cells(28, j).Value = "0"
        .Cells(30, j).NumberFormat = "0%"
    Next j
End With

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

Thanks,
Spi

Which part of the Summary sheet do you need the macro to populate? The entire sheet?

Yes please..."The entire sheet" Sorry should have been precise in my request!

Thank you!

Try this code -

Option Explicit

Sub scoring()
Dim i As Long, j As Long, lcol As Long, lrow As Long

Application.ScreenUpdating = False

Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Summary"
Worksheets("Summary").Range("A1:D1").Value = Split("Respondent name, Question, Correct Answer,Answered Incorrectly", ",")
Worksheets("Summary").Rows(1).Font.Bold = True

With Worksheets("Questions and Answers")
    lcol = .Range("IV1").End(xlToLeft).Column
    For j = 3 To lcol
        For i = 2 To 26
            If .Cells(i, j).Value = Worksheets("Correct Answer").Range("C" & i).Value Then
                .Cells(27, j).Value = .Cells(27, j).Value + 1
            Else
                .Cells(28, j).Value = .Cells(28, j).Value + 1
                .Cells(i, j).Interior.Color = 255
                Worksheets("Correct Answer").Range("D" & i).Value = Worksheets("Correct Answer").Range("D" & i).Value + 1
                lrow = Worksheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
                Worksheets("Summary").Range("A" & lrow + 1).Value = .Cells(1, j).Value
                Worksheets("Summary").Range("B" & lrow + 1).Value = .Cells(i, 2).Value
                Worksheets("Summary").Range("C" & lrow + 1).Value = Worksheets("Correct Answer").Cells(i, 3).Value
                Worksheets("Summary").Range("D" & lrow + 1).Value = .Cells(i, j).Value
            End If
        Next i
        .Cells(29, j).FormulaR1C1 = "=COUNTA(R[-26]C:R[-2]C)"
        .Cells(30, j).Value = .Cells(27, j) / .Cells(29, j)
        If .Cells(28, j).Value = "" Then .Cells(28, j).Value = "0"
        .Cells(30, j).NumberFormat = "0%"
    Next j
End With

Worksheets("Summary").Cells.EntireColumn.AutoFit

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

Works seamlessly! Thanks again...

You rock!

Regards,
Spi

Ok, great. We can mark this thread as solved then.

Yes yes…But I think I had already marked it as “Solved” even before the addition came in, no?

Sorry in case am missing anything....