Macro Not Tracking Total Score Correctly

Logit · #1 03-26-2023, 08:22 AM

I've been working this challenge for a week without success. Time to get outside help.

Macro records one less correct answer than actually exists. So ... if there are ten correct answers the macro records NINE ... then takes the remainder ( ONE ) and applies it to the next user. If you run the program, selecting all of the correct answers, then look at the RECORD sheet you'll see the NINE and the ONE in Column C.

Your assistance is appreciated. I am open to having the code changed in any manner that will result in a correct result.

Thank you.

Code:

Option Explicit

Private btnClicked As String 'A, B, C, D
Private questionNo As Integer
Private question As String, code As String
Private choiceA, choiceB, choiceC, choiceD As String
Private answer As String

 

Private Sub cmdA_Click()
cmdA.BackColor = &HFF00&
cmdB.BackColor = &HC0FFFF
cmdC.BackColor = &HC0FFFF
cmdD.BackColor = &HC0FFFF
btnClicked = "Answer: A"""
End Sub

Private Sub cmdB_Click()
cmdA.BackColor = &HC0FFFF
cmdB.BackColor = &HFF00&
cmdC.BackColor = &HC0FFFF
cmdD.BackColor = &HC0FFFF
btnClicked = "Answer: B"""
End Sub

Private Sub cmdC_Click()
cmdA.BackColor = &HC0FFFF
cmdB.BackColor = &HC0FFFF
cmdC.BackColor = &HFF00&
cmdD.BackColor = &HC0FFFF
btnClicked = "Answer: C"""
End Sub

Private Sub cmdD_Click()
cmdA.BackColor = &HC0FFFF
cmdB.BackColor = &HC0FFFF
cmdC.BackColor = &HC0FFFF
cmdD.BackColor = &HFF00&
btnClicked = "Answer: D"""
End Sub

Sub resetButton()
cmdA.BackColor = &HC0FFFF
cmdB.BackColor = &HC0FFFF
cmdC.BackColor = &HC0FFFF
cmdD.BackColor = &HC0FFFF
End Sub

 

Private Sub cmdSubmit_Click()
'Check if user click an option
If cmdA.BackColor = &HFF00& Or cmdB.BackColor = &HFF00& Or _
cmdC.BackColor = &HFF00& Or cmdD.BackColor = &HFF00& Then

'Move to the next question
questionNo = questionNo + 1
Label1.Caption = "Question " & questionNo & " of 10"



If cmdSubmit.Caption = "Submit" Then
Call get_quiz
Dim lRow As Integer
lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
rSH.Range("C" & lRow).Value = rSH.Range("C" & lRow).Value + 1
'rSH.Range("Y1").Value = frm_score.lblScore
txtSampleCode.Text = rSH.Range("C" & lRow).Value
ElseIf cmdSubmit.Caption = "End Exam" Then

'Save the quiz result to record sheet
lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
rSH.Range("A" & lRow).Value = username
rSH.Range("B" & lRow).Value = Now


frm_score.lblName = username
frm_score.lblScore = rSH.Range("C" & lRow).Value + 1
frm_score.Show
Unload Me
End If

Else
MsgBox "Please select an answer.", vbExclamation, mTitle
End If
End Sub

Private Sub UserForm_Initialize()
questionNo = 1
Call init_SH
Call get_quiz
End Sub

Sub get_quiz()
Call resetButton
Dim lRow As Integer
lRow = questionNo + 1

question = qSH.Range("A" & lRow).Value

choiceA = qSH.Range("B" & lRow).Value
choiceB = qSH.Range("C" & lRow).Value
choiceC = qSH.Range("D" & lRow).Value
choiceD = qSH.Range("E" & lRow).Value
answer = qSH.Range("F" & lRow).Value

txtQuestion.Value = question
cmdA.Caption = choiceA
cmdB.Caption = choiceB
cmdC.Caption = choiceC
cmdD.Caption = choiceD

If qSH.Range("A" & lRow).Value = "" Then
'Last question
'cmdSubmit.Caption = "End Exam"
Unload Me
'Save the quiz result to record sheet
lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
rSH.Range("A" & lRow).Value = username
rSH.Range("B" & lRow).Value = Now


frm_score.lblName = username
frm_score.lblScore = rSH.Range("C" & lRow).Value
frm_score.Show
Unload Me

End If
End Sub

Logit · #2 03-27-2023, 10:46 AM

Please provide some assistance ...

Quote:

Originally Posted by logit

i've been working this challenge for a week without success. Time to get outside help.

Macro records one less correct answer than actually exists. So ... If there are ten correct answers the macro records nine ... Then takes the remainder ( one ) and applies it to the next user. If you run the program, selecting all of the correct answers, then look at the record sheet you'll see the nine and the one in column c.

Your assistance is appreciated. I am open to having the code changed in any manner that will result in a correct result.

Thank you.

Code:

option explicit

private btnclicked as string 'a, b, c, d
private questionno as integer
private question as string, code as string
private choicea, choiceb, choicec, choiced as string
private answer as string

 

private sub cmda_click()
cmda.backcolor = &hff00&
cmdb.backcolor = &hc0ffff
cmdc.backcolor = &hc0ffff
cmdd.backcolor = &hc0ffff
btnclicked = "answer: A"""
end sub

private sub cmdb_click()
cmda.backcolor = &hc0ffff
cmdb.backcolor = &hff00&
cmdc.backcolor = &hc0ffff
cmdd.backcolor = &hc0ffff
btnclicked = "answer: B"""
end sub

private sub cmdc_click()
cmda.backcolor = &hc0ffff
cmdb.backcolor = &hc0ffff
cmdc.backcolor = &hff00&
cmdd.backcolor = &hc0ffff
btnclicked = "answer: C"""
end sub

private sub cmdd_click()
cmda.backcolor = &hc0ffff
cmdb.backcolor = &hc0ffff
cmdc.backcolor = &hc0ffff
cmdd.backcolor = &hff00&
btnclicked = "answer: D"""
end sub

sub resetbutton()
cmda.backcolor = &hc0ffff
cmdb.backcolor = &hc0ffff
cmdc.backcolor = &hc0ffff
cmdd.backcolor = &hc0ffff
end sub

 

private sub cmdsubmit_click()
'check if user click an option
if cmda.backcolor = &hff00& or cmdb.backcolor = &hff00& or _
cmdc.backcolor = &hff00& or cmdd.backcolor = &hff00& then

'move to the next question
questionno = questionno + 1
label1.caption = "question " & questionno & " of 10"



if cmdsubmit.caption = "submit" then
call get_quiz
dim lrow as integer
lrow = rsh.range("a" & rows.count).end(xlup).row + 1
rsh.range("c" & lrow).value = rsh.range("c" & lrow).value + 1
'rsh.range("y1").value = frm_score.lblscore
txtsamplecode.text = rsh.range("c" & lrow).value
elseif cmdsubmit.caption = "end exam" then

'save the quiz result to record sheet
lrow = rsh.range("a" & rows.count).end(xlup).row + 1
rsh.range("a" & lrow).value = username
rsh.range("b" & lrow).value = now


frm_score.lblname = username
frm_score.lblscore = rsh.range("c" & lrow).value + 1
frm_score.show
unload me
end if

else
msgbox "please select an answer.", vbexclamation, mtitle
end if
end sub

private sub userform_initialize()
questionno = 1
call init_sh
call get_quiz
end sub

sub get_quiz()
call resetbutton
dim lrow as integer
lrow = questionno + 1

question = qsh.range("a" & lrow).value

choicea = qsh.range("b" & lrow).value
choiceb = qsh.range("c" & lrow).value
choicec = qsh.range("d" & lrow).value
choiced = qsh.range("e" & lrow).value
answer = qsh.range("f" & lrow).value

txtquestion.value = question
cmda.caption = choicea
cmdb.caption = choiceb
cmdc.caption = choicec
cmdd.caption = choiced

if qsh.range("a" & lrow).value = "" then
'last question
'cmdsubmit.caption = "end exam"
unload me
'save the quiz result to record sheet
lrow = rsh.range("a" & rows.count).end(xlup).row + 1
rsh.range("a" & lrow).value = username
rsh.range("b" & lrow).value = now


frm_score.lblname = username
frm_score.lblscore = rsh.range("c" & lrow).value
frm_score.show
unload me

end if
end sub

Logit · #3 03-28-2023, 03:50 AM

The current code is logging the data onto the RECORD sheet like this :

Internxt Drive

When it should be logged like this :

Internxt Drive

NoSparks · #4 03-28-2023, 01:33 PM

try

Code:

Private Sub cmdSubmit_Click()
    Dim lRow As Integer

'Check if user click an option
If cmdA.BackColor = &HFF00& Or cmdB.BackColor = &HFF00& Or _
   cmdC.BackColor = &HFF00& Or cmdD.BackColor = &HFF00& Then
    
    'Move to the next question
    questionNo = questionNo + 1
    Label1.Caption = "Question " & questionNo & " of 10"
    
    If cmdSubmit.Caption = "Submit" Then
        lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
        
        rSH.Range("C" & lRow).Value = rSH.Range("C" & lRow).Value + 1
        'rSH.Range("Y1").Value = frm_score.lblScore
        txtSampleCode.Text = rSH.Range("C" & lRow).Value
        
        Call get_quiz
        
    ElseIf cmdSubmit.Caption = "End Exam" Then

        'Save the quiz result to record sheet
        lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
        rSH.Range("A" & lRow).Value = username
        rSH.Range("B" & lRow).Value = Now

        frm_score.lblName = username
        frm_score.lblScore = rSH.Range("C" & lRow).Value + 1
        frm_score.Show
        Unload Me
    End If

Else
    MsgBox "Please select an answer.", vbExclamation, mTitle
End If

End Sub

Logit · #5 03-28-2023, 02:21 PM

NoSparks:

Thank you for your assistance.

If there are less than the total number of questions that have been accurately answered, the macro is not reflecting such. i.e., If only 8 questions were correctly answered the RECORD sheet still shows 10.

???

NoSparks · #6 03-28-2023, 03:00 PM

Code:

Private Sub cmdSubmit_Click()
    Dim lRow As Integer

'Check if user click an option
If cmdA.BackColor = &HFF00& Or cmdB.BackColor = &HFF00& Or _
   cmdC.BackColor = &HFF00& Or cmdD.BackColor = &HFF00& Then
    
    'Move to the next question
    questionNo = questionNo + 1
    Label1.Caption = "Question " & questionNo & " of 10"
    
    If cmdSubmit.Caption = "Submit" Then
        lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
        If Mid(btnClicked, 9, 1) = answer Then
            rSH.Range("C" & lRow).Value = rSH.Range("C" & lRow).Value + 1
            'rSH.Range("Y1").Value = frm_score.lblScore
            txtSampleCode.Text = rSH.Range("C" & lRow).Value
        End If
        
        Call get_quiz
        
    ElseIf cmdSubmit.Caption = "End Exam" Then

        'Save the quiz result to record sheet
        lRow = rSH.Range("A" & Rows.Count).End(xlUp).Row + 1
        rSH.Range("A" & lRow).Value = username
        rSH.Range("B" & lRow).Value = Now

        frm_score.lblName = username
        frm_score.lblScore = rSH.Range("C" & lRow).Value + 1
        frm_score.Show
        Unload Me
    End If

Else
    MsgBox "Please select an answer.", vbExclamation, mTitle
End If

End Sub

Logit · #7 03-28-2023, 03:05 PM

NoSparks ... thank you. Thank solved the issue.

After one week of staring at the code it all kept looking the same. I wasn't making any progress. Your help is SO GRATEFULLY APPRECIATED !!!

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Total float not calculating correctly	praneetbvb	Project	0	04-30-2020 10:17 AM
Need to tally check boxes (labeled 1-5) on performance review to get total score based on box value.	Learners Permit	Word	2	07-16-2018 07:56 PM
Macro functioning correctly	H28Sailor	Excel Programming	2	12-11-2016 03:18 PM
Ad a quiz with different scores for each question and with final score at the end	Amadeus	PowerPoint	0	09-16-2014 04:24 AM
How to invoke the macro correctly in the workflow	smndnm	Word VBA	6	07-08-2014 03:13 AM