Updating caption name to the Option Button

[Pavan.Sada.PS]

Dear Friends,

Please look at the attached file and access sub routine QuestionPaper_O2C_Germany which is in Sheet3.

I am trying to assign value to a variable based on the cell value in sheet mentioned in the Range(QPName)

In case of cell contains any value <> to x then option button caption has to be updated with the cell value else (empty cases) option button has to be disabled.

I think I have a problem with the below part of the code.

Dim i As Integer
Dim Answer As String
  Set ws = Sheet3
  For ObjNum = 1 To ws.OLEObjects.Count
  Set obj = ws.OLEObjects(ObjNum)
  Set objobject = obj.Object
  '--------------------------------------------------------------
  If TypeName(objobject) = "OptionButton" Then
  If "Opn" & ObjNum <> Empty Then
  Answer = "Opn" & ObjNum
  objobject.Caption = Answer
  Else
  objobject = 0
  End If
  End If
  Next ObjNum

 

[p45cal]

Generally, if you have lots of code repeated that is very similar, you can usually shorten it; look at the bit that's different and put a variable there. Have a play with attached. I haven't done anything with updating column AV of the Question Paper sheet. I don't know how you want to answer or score questions 2, 12 and 15.
Otherwise have a look at the HideSheetsAndSetQPName (in the Main sheet code-module) and QuestionPaper (in module4) subs. Both take arguments to decide what to do.

Here's a link to the file:

 

[Pavan.Sada.PS]

Hey Friend,

One word to say abt you; Awsome..

I have still on the learning curve.. all the codes that I have designed is based on the learning made from the VBA books. Its good to learn and try implementing new ways. Coming back to the point..

May i buy in you time and ask you for a little more help.. plz..

The codes used were really awful and the request from my side is .. if you can update the comments to explain on the codes used in Module 4 which would be of great help to me so i can learn and understand the design of code. (which i am failing at the moment)

Let me explain the overview of this file.. There will be 18 sets of Question paper and out of which 17 will be of the same format (12 Objective 2 Match the following and 1 Multiple choice) and 1 question paper (Costing UK - R2R) will have 14 Objective and 1 Multiple choice).

17 Q.papers will follow the template of (Question Paper) sheet and was thinking to create another one for the exception. (If we can accommodate in same sheet? that would be great)

About validation process. As soon as the user submits the answers.. Range(AV18:AY32) will be copied and pasted to the respective QPName listed in its range. (Look at the attached file and i have drafted the validation process in sheet "O2C Germany")

Regards,
Pavan S

 

[p45cal]

if you can update the comments to explain on the codes used in Module 4 which would be of great help to me so i can learn and understand the design of code. (which i am failing at the moment)

It takes longer to comment/explain (especially when one doesn't know the level of the person you're explaining to) than to write the code. Perhaps if you asked specific questions about small parts of the code you don't understand, one or two at a time.

Let me explain the overview of this file.. There will be 18 sets of Question paper and out of which 17 will be of the same format (12 Objective 2 Match the following and 1 Multiple choice) and 1 question paper (Costing UK - R2R) will have 14 Objective and 1 Multiple choice).

It's a pain that one paper has to be different. Why can't they be all the same? Of course it can be coded for, but one wonders if the effort going into catering for the exception exceeds the effort of changing the one paper.

About validation process. As soon as the user submits the answers.. Range(AV18:AY32) will be copied and pasted to the respective QPName listed in its range. (Look at the attached file and i have drafted the validation process in sheet "O2C Germany")

I'm unlikely to have time to look at his today. I will look later.

 

[Pavan.Sada.PS]

It's a pain that one paper has to be different. Why can't they be all the same? Of course it can be coded for, but one wonders if the effort going into catering for the exception exceeds the effort of changing the one paper.

Yes, I do understand that. But the question papers are being set by 18 different persons and the exception paper is set a person who is 3 positions upper than me (who is equaling to VP). After all the efforts made to explain him on the format of questions he comes out with an answer "No options, I want this in my way or No Way".

I have no option to fire him from this company so I have take this as an exception.

It takes longer to comment/explain (especially when one doesn't know the level of the person you're explaining to) than to write the code. Perhaps if you asked specific questions about small parts of the code you don't understand, one or two at a time.

Plz have a look at the file attached in this thread.. I have updated comments based on my understanding. Let me know if I have mis understood any of the lines.

Also added few codes to enable the lables at the end of the code.

 

[p45cal]

After all the efforts made to explain him on the format of questions he comes out with an answer "No options, I want this in my way or No Way".

To the pratt who says this my inclination would be to say "OK, No way." Next best is to produce your work, but, because his paper is the exception, when people click on his paper, have a message pop up that says something along the lines of "Coming soon… (Due to the difference in format of this question paper it is currently unavailable. All other papers are available.)"
I'm not going to code for it, others here might. Start a new thread referring to this one perhaps.

Plz have a look at the file attached in this thread.. I have updated comments based on my understanding. Let me know if I have mis understood any of the lines.

OK, this line and comment:
Set thisQ = .Cells(rw, 3) 'Assigning cell value to a variable and later will be used to upate the caption for the lables used in this sheet

Because this line begins with Set, the variable thisQ is not being assigned a value, but a single cell range. (You can thisQ.Select and it will select the cell (if on the right sheet).) This allows thisQ.offset to be used later in the code.

Otherwise you seem to have it all right!

Also added few codes to enable the lables at the end of the code.

I'm only able to gain access to a machine which has xl 2003 at the moment and even though it has the compatibility pack installed the activeX objects aren't playing, so I can't test. I'm not sure why the lines you added might be necessary?

 

[Pavan.Sada.PS]

Hello Friend,

Thanks for the advice.. I will hve the work around for the exceptional case.. plz assist me on the validation of answers for the rest of the Qpapers.

I'm not sure why the lines you added might be necessary?

Once I Execute load questions macro. It use to disable the label's so I have used the code to enable it.

 

[p45cal]

Check out the attached where I have added a sub which runs when the Submit button is clicked. It scores the current paper but does NOT assess questions 2, 12 and 15 at all.
For questions 2 and 12 I don't know how you want the examinee to answer those questions.
For question 15 I don't know how you want to score the answer (a quarter point for every correct answer or a total 0 if any checkbox is incorrect…)

 

[p45cal]

Once I Execute load questions macro. It use to disable the label's so I have used the code to enable it.

I don't think you need those lines now.

 

[Pavan.Sada.PS]

Hey Friend, (May I ask your name?)

Thanks for the codes.. Looks great.. But need a small tweak in the design to match my current requirement.

Plz have a look at the attached file.

As soon as I click on submit button, User answers have to be pasted in Answer Log sheet in rage(D9:G23) either in the format attached in the file or TRUE's can be replaced with ABCD's

Please have a look at the O2C Germany sheet. I have explained the validation process for match the following (2&12) and multiple choice (15) questions.

Assessment score = total value gained / 15


Was thinking abt the chance to put control on the employees accessing the question papers other teams.

Please look the Access list.

Column C to Column AK are the Employee ID's and there is a table next to it for the employee list

Admin 1,2,3 will have access to view and answer all the question papers. starting from row 5 and below (6,7,8.....) will have restricted access based on the team level.

What I have in my mind is... will get the user name = (EmpName) through Function UserName() and look though the possible match for the EmpName in the EmpNameList range and ask for the confirmation from user by showing their EmpID along with possible match of EmpName

After this to execute the sub routine Loadquestions()..

Incase the if the first possible match is not confirmed by the user it has look for the next possible match.. if the possible matches are not correct then ask for the UserName and to repeat the steps for finding possible match.

(this repeat step is needed because. I provide my lappy to the other user to complete the assessement as excel app is not installed in his desktop so UserName function will look for the possible match of pavan which is incorrect so it has to repeat the step after asking the username)

If it fails to get the possible match then exit sub with the message cotact admin

Regards,
Pavan. S

 

[Pavan.Sada.PS]

What I have in my mind is... will get the user name = (EmpName) through Function UserName() and look though the possible match for the EmpName in the EmpNameList range and ask for the confirmation from user by showing their EmpID along with possible match of EmpName

After this to execute the sub routine Loadquestions()..

Incase the if the first possible match is not confirmed by the user it has look for the next possible match.. if the possible matches are not correct then ask for the UserName and to repeat the steps for finding possible match.

(this repeat step is needed because. I provide my lappy to the other user to complete the assessement as excel app is not installed in his desktop so UserName function will look for the possible match of pavan which is incorrect so it has to repeat the step after asking the username)

If it fails to get the possible match then exit sub with the message cotact admin

With regard to the quote,.. Please look at the attached file.. I have drafted a code.. It gives me result.. but while testing with possibilities it gives me some error messages and I am bad at overcoming those error messages.

 

[p45cal]

I can't do anything at the moment, I'm not near a machine which has Excel 2007 or later on it.

 

[Pavan.Sada.PS]

No worries.. I will wait..

 

[p45cal]

I've had a little time on a machine with a more recent version of Excel, but only to make alterations to my Score sub. So far only to work out the score, not yet to put values on the Answer log sheet.
It raised a question regarding scoring question 15; your scoring method will give the student full marks if they tick every box in question 15. I feel there must be a penalty if the student does this (and the correct answer is not for all 4 boxes to be ticked).

So if the answer is A and B, and he ticks all 4 boxes, he should get 0

If the answer is A, B and C and he ticks all 4 boxes what should his score be? I don't think it should be 1. (I'm not even sure it should be 0.5!)

Anyway, a sticky one. Here's the altered Score sub code so far:

Sub Score()
Set rngStudentAnswers = Sheets("Question Paper").Range("AV18:AY32")
Set rngAnswerLog = Sheets("Answer Log").Range("D9:G23")
rngAnswerLog.Cells = Empty
QNo = 0: CorrectCount = 0: IncorrectCount = 0: UnansweredCount = 0
For Each are In Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74").Areas
  QNo = QNo + 1
  '  Application.Goto are
  '  Application.Goto rngStudentAnswers.Rows(QNo)
  Select Case QNo
    Case 2, 12
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), 0) = 4 Then
        UnansweredCount = UnansweredCount + 1
      Else
        Count = 1
        For Each cll In are.Cells
          If cll.Value = rngStudentAnswers.Rows(QNo).Cells(Count).Value Then
            CorrectCount = CorrectCount + 0.25
          Else
            If rngStudentAnswers.Rows(QNo).Cells(Count).Value = Empty Then
              UnansweredCount = UnansweredCount + 0.25
            Else
              IncorrectCount = IncorrectCount + 0.25
            End If
          End If
          Count = Count + 1
        Next cll
      End If
    Case 15
      'Stop
'this bit complex because it allows for the answer sheet to have the answers in any order:
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), True) = 0 Then
        UnansweredCount = UnansweredCount + 1
      Else
        Count = 1
        Divisor = Application.WorksheetFunction.CountA(are)
        For Each cll In rngStudentAnswers.Rows(QNo).Cells
          If cll.Value = True Then
          StudentTickedCorrectly = False
            For Each cel In are.Cells
              If Choose(Count, "A", "B", "C", "D") = Application.Trim(cel.Value) Then
                CorrectCount = CorrectCount + 1 / Divisor
                StudentTickedCorrectly = True
                Exit For
              End If
            Next cel
            If Not StudentTickedCorrectly Then IncorrectCount = IncorrectCount + 1 / Divisor
          End If
          Count = Count + 1
        Next cll
      End If
    Case Else
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), True) = 0 Then
        UnansweredCount = UnansweredCount + 1
      Else
        StudentAnswer = Choose(Application.Match(True, rngStudentAnswers.Rows(QNo), 0), "A", "B", "C", "D")
        If StudentAnswer = Application.Trim(are.Value) Then CorrectCount = CorrectCount + 1 Else IncorrectCount = IncorrectCount + 1
      End If
  End Select
Next are
MsgBox "Correct: " & CorrectCount & vbLf & "Incorrect: " & IncorrectCount & vbLf & "Unanswered: " & UnansweredCount
End Sub

There are changes elsewhere to the code and some formulae added to cells AV19:AY19,AV29:AY29 in the Question Paper sheet.

 

[Pavan.Sada.PS]

Hello Friend,

There is a hypothetical situation here. These question paper decides one's Job in the company and hence I cant entertain employee ticking all 4 to get 1 marks or I cant give him 0 Marks because he selected few right answers. But I have decided to go with the negative marking

So if the answer is A and B, and he ticks all 4 boxes, he should get 0

This is correct he will get 0 if he checks all the 4 boxes and 0.5 if he checks 3 boxes

If the answer is A, B and C and he ticks all 4 boxes what should his score be? I don't think it should be 1. (I'm not even sure it should be 0.5!)

In this case one right option = 1/3 .

So if he checks all the four boxes then he would get (1/3)*2

Regards,
Pavan S

 

[Pavan.Sada.PS]

Hey Friend..

I have gone through your score code.. I have updated my comments to each of the line.. Let me know if I have misunderstood or misspelled any of the code

Sub Score()
Set rngStudentAnswers = Sheets("Question Paper").Range("AV18:AY32")    ' Student's choices will be updated in the Range("AV18:AY32")
Set rngAnswerLog = Sheets("Answer Log").Range("D9:G23")                ' Answers will be pasted in AnswerLog sheet in Range("D9:G23")
rngAnswerLog.Cells = Empty                                              ' Clearing the values Answer Log cells
QNo = 0: CorrectCount = 0: IncorrectCount = 0: UnansweredCount = 0      ' Defining the variables to hold the score/count of right / Wrong / Q.no's etc
For Each are In Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74").Areas      'Look into each cells listed in the question paper (Answer Cells)
  QNo = QNo + 1                                                        ' Loop through all the questions from QNo 1 till QNo 15
  '  Application.Goto are
  '  Application.Goto rngStudentAnswers.Rows(QNo)
  Select Case QNo
    Case 2, 12                                                                              ' In case of QNo 2 or 12 (Match the Following)
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), 0) = 4 Then    ' If Range(AV19:AY19) or Range(AV29:AY29) count condition is 0, i.e, if total count of 0's in this range adds up to 4 then
        UnansweredCount = UnansweredCount + 1                                              ' Consider it as unanswered
      Else                                                                                  ' In all other cases
        Count = 1                                                                          ' Variable defined to look into all 4 cells in range listed below from 1 to 4
        For Each cll In are.Cells                                                          ' Loop through each of the cells in QPaper.Range(E9:H9) or QPaper.Range(E59:H59)
          If cll.Value = rngStudentAnswers.Rows(QNo).Cells(Count).Value Then                ' Case Right Answers: Sample: If QP.Range(E9) = Answersheet.Range(AV19) & QP.Range(F9) = Answersheet.Range(AW19) & QP.Range(G9) = Answersheet.Range(AX19) & QP.Range(H9) = Answersheet.Range(AY19) then
            CorrectCount = CorrectCount + 0.25                                              ' Giving them .25 Marks
          Else                                                                              ' In All other cases
            If rngStudentAnswers.Rows(QNo).Cells(Count).Value = Empty Then                  ' Case of left blank cells
              UnansweredCount = UnansweredCount + 0.25                                      ' Consider as unanswered Part of question
            Else                                                                            ' Else treat it as Incorrect Answer
              IncorrectCount = IncorrectCount + 0.25
            End If
          End If
          Count = Count + 1
        Next cll
      End If
    Case 15                                                                                ' In case of QNo 15 (Multiple Choice Question)
      'Stop
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), True) = 0 Then  ' If Range(AV32:AY32) count condition is TRUE , i.e, if total count of TRUE's in this range adds up to 0 then
        UnansweredCount = UnansweredCount + 1                                              ' Consider it as unanswered
      Else
        Count = 1                                                                          ' Variable defined to look into all 4 cells in range listed below from 1 to 4
        Divisor = Application.WorksheetFunction.CountA(are)                                ' Variable defined to hold the count of expected answers which will be used to arive at the value for one right answer
        For Each cll In rngStudentAnswers.Rows(QNo).Cells                                  ' Loop through each of the cells in AnswerSheet.Range(AV32:AY32)
          If cll.Value = True Then                                                          ' If the cell value is mentioned as TRUE then
          StudentTickedCorrectly = False                                                    ' Set default answer as FALSE for the variable so that Test will be executed in next step
            For Each cel In are.Cells                                                      ' Loop through each of the cells in QP.Range(E74:H74)
              If Choose(Count, "A", "B", "C", "D") = Application.Trim(cel.Value) Then      ' Using choose function to get the character and then matching will be done againt the expected answer in QP.Range(E74:H74), in case of matching scenario
                CorrectCount = CorrectCount + (1 / Divisor)                                ' Consider it correct answer
                StudentTickedCorrectly = True
                Exit For
              End If
            Next cel
            If Not StudentTickedCorrectly Then IncorrectCount = IncorrectCount + (1 / Divisor) ' If StudentTickedCorrectly = False then consider it as incorrect answer
          End If
          Count = Count + 1
        Next cll
      End If
    Case Else                                                                              ' In case of rest fo the objective type Questions
      If Application.WorksheetFunction.CountIf(rngStudentAnswers.Rows(QNo), True) = 0 Then  ' If Answersheet.Range(AV--:AY--) count condition is TRUE , i.e, if total count of TRUE's in this range adds up to 0 then
        UnansweredCount = UnansweredCount + 1                                              ' Consider it as unanswered
      Else
        StudentAnswer = Choose(Application.Match(True, rngStudentAnswers.Rows(QNo), 0), "A", "B", "C", "D") ' Consider the First Question: In Answersheet.Range(AV18:Ay18). Match the word TRUE in the Answersheet.Range with exact match, get the output as the Integer and by using this Integer as output in choose function will populate the character.
        If StudentAnswer = Application.Trim(are.Value) Then CorrectCount = CorrectCount + 1 Else IncorrectCount = IncorrectCount + 1 'If StudentAnswer Matches to Expected Answer. i.e, StudentAnswer = QP.Range(E4) then consider it as right else consider it as incorrect
      End If
  End Select
Next are
MsgBox "Correct: " & CorrectCount & vbLf & "Incorrect: " & IncorrectCount & vbLf & "Unanswered: " & UnansweredCount
End Sub

 

[p45cal]

I am finally at a machine with Excel 2013 on it. I will look at this in the next few days.

 

[Pavan.Sada.PS]

Hey Friend,

Thanks you for the update. No worries. As I had to conduct assessments for few of the candidates I had to fix this for the temporary solution. Hence I have worked on the file to get out required. I have altered few codes to get the outputs right and also to match the business requirements.

Here is the completed file which gives me the out put as required.

password to open the vba module is : pavansada08143@yahoo.com

 

[p45cal]

I've had a look at the scoring code and it seems OK. It could be a little slicker, but it's fine!

 

[Pavan.Sada.PS]

Hey Friend,

Thanks a lot for all your help and time dedicated on my post.. I have learn t a lot from your code. However I am unable to apply the concept of Areas (For Each are In Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74").Areas ) which you have used in scoring code to my other examples. Somehow I fail to understand the concept of this code.

If you could share some of the basic examples to understand this concept that would be of great help to me and others viewing this thread.

Finally a Last word to say.. I know You are in Awsome state already, and wish you to gain much more awesomeness

Regards,
Pavan

 

[p45cal]

Will respond on Friday (tomorrow).

 

[p45cal]

Sub blah()
Step through this macro with F8 on the keyboard.
'If you do this:
Application.Goto Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74")
'you'll see the cells that comprise the above range selected. The selection is made up of discrete areas (a non-contiguous selection). These areas are what the loop loops through; viz.:
'or if you already have the correct sheet as the active sheet:
'Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74").Select
For Each are In Sheets(Range("QPName").Value).Range("E4,E9:H9,E14,E19,E24,E29,E34,E39,E44,E49,E54,E59:H59,E64,E69,E74:F74").Areas
are.Select
Next are
End Sub