Hi,
I am trying to create a multiple choice test in Excel 2010. I know nothing about programming in VBA.
I would like to thank Joe Was for his excellent contribution on creating a MCQ quiz in Excel.
I have compiled the following code from his various posts. However I have two questions:
1. The code for the print option prints two columns - the correct answers in the first column and the responses in the second column and mentions whether it is correct or wrong. To prevent the students from cheating by taking the printout and then attempt it again with the right answers, I prefer the right answers are not printed. How do I do this.
2. The printout gives the system time when the test was completed. I would like to add the start time of the test and also calculate the total time taken for the test. Please help me with the code for inserting the start time and calculating the total time taken and also please let me know where exactly I should place this portion in the original code.
Many thanks in advance.
Vijay
The code which I have compiled from earlier posts - Thanks again to Joe Was - is as below:
Public myQMsg$, myQTitle$, myQDefault$, myQResp$, myRespK$, mySw As Boolean
'*** Change your Test Title Here! ***
Public Const myTestTitle$ = "Welcome to the Test One Exam!"
'********************************************************************
Private Sub myLoadQuestions()
Dim tSht%, eSht%, tSht2%, eSht2%, tShts1%, eShts1%, tShts2%, eShts2%
Dim myMsg$, myTitle$, myDefault$, myResp$
Dim ws As Worksheet, myNewSht As Worksheet
myTitle = "Change this Tests Title?"
On Error GoTo mySkip
If Sheets("Start").Range("A3").Value <> "" Then
myDefault = Sheets("Start").Range("A3").Value
Else
mySkip:
myDefault = myTestTitle
End If
myMsg = "The current test title is:" & vbLf & vbLf & _
myDefault & vbLf & vbLf & _
"If you want to change this tests title," & vbLf & _
"do so now!"
myResp = InputBox(myMsg, myTitle, myDefault)
tSht = Worksheets.Count
For Each ws In Worksheets
eSht = eSht + 1
If ws.Name = "Start" Then GoTo gotSht
If tSht = eSht Then GoTo mkSht
Next ws
mkSht:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Start"
Sheets("Start").Move After:=Sheets(tSht + 1)
gotSht:
Sheets("Start").Select
Sheets("Start").Range("A3").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 18
End With
Sheets("Start").Range("A3").Value = myResp
On Error GoTo myAdd
If ActiveSheet.Shapes.Count = 0 Then GoTo myAdd
ActiveSheet.Shapes("myButton").Delete
myAdd:
With Sheets("Start").Shapes.AddShape(msoShapeBevel, 172, 105, 90, 33)
.Name = "myButton"
End With
ActiveSheet.Shapes("myButton").Select
With Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 26
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 18
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
ActiveSheet.Shapes("myButton").Select
Selection.Characters.Text = "Start"
With Selection.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 14
.ColorIndex = 11
End With
ActiveSheet.Shapes("myButton").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.AutoSize = False
End With
ActiveSheet.Shapes("myButton").Select
Selection.OnAction = "myDoQuestions"
Range("A1").Select
'********************************************************************
tSht2 = Worksheets.Count
For Each ws In Worksheets
eSht2 = eSht2 + 1
If ws.Name = "Info" Then GoTo gotShtB
If tSht2 = eSht2 Then GoTo mkShtB
Next ws
mkShtB:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Info"
Sheets("Info").Move After:=Sheets(tSht2 + 1)
gotShtB:
Sheets("Info").Select
Sheets("Info").Range("A1").Select
'********************************************************************
tShts1 = Worksheets.Count
For Each ws In Worksheets
eShts1 = eShts1 + 1
If ws.Name = "Questions" Then GoTo gotSht1
If tShts1 = eShts1 Then GoTo mkSht1
Next ws
mkSht1:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Questions"
Sheets("Questions").Move After:=Sheets(tShts1 + 1)
gotSht1:
If Sheets("Questions").Visible = False Then _
Sheets("Questions").Visible = True
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Columns("A:A").ColumnWidth = 128
Sheets("Questions").Range("A1").Select
'********************************************************************
tShts2 = Worksheets.Count
For Each ws In Worksheets
eShts2 = eShts2 + 1
If ws.Name = "Answers" Then GoTo gotSht2
If tShts2 = eShts2 Then GoTo mkSht2
Next ws
mkSht2:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Answers"
Sheets("Answers").Move After:=Sheets(tShts2 + 1)
gotSht2:
If Sheets("Answers").Visible = False Then _
Sheets("Answers").Visible = True
Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Answers").Range("A1").Select
Sheets("Questions").Select
'********************************************************************
For Each ws In Worksheets
If ws.Name = "Start" Or ws.Name = "Info" Or ws.Name = "Questions" Or ws.Name = "Answers" Then
GoTo myNotDel
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
myNotDel:
Next ws
Call displayLoadInst
End Sub
Sub displayLoadInst()
Application.MacroOptions Macro:="displayLoadInst", Description:= _
"Show the Load Questions Instructions!", ShortcutKey:="i"
MsgBox "Instructions: Type your Questions in Column: A," & vbLf & _
"Starting in Row: 1, Cell: A1 of the Sheet Named ""Questions""" & vbLf & _
"One Question per Row-Cell!" & vbLf & vbLf & _
"Like: On Sheet ""Questions"" Cell: ""A1"" Add:" & vbLf & vbLf & _
"Select the best answer: A, B, C, D or E. [Note: For a new line in your Question, Hit: Alt + Enter]" & vbLf & _
"1 + 1 = ? [Note: For a BLANK Line in your Question, Hit: Alt + Enter, two times!]" & vbLf & vbLf & _
" A). 1.1, B). 1, C). 2, D). 4, E). None of these answers! [Note: Add Spacing as needed!] " & vbLf & _
vbLf & vbLf & "Then Add Each Question's Answer to the Same Cell on the Sheet Named: ""Answers""" & _
vbLf & vbLf & "Like for the Sample Question Above on Sheet ""Answers"" Cell: A1:" & vbLf & "C" & _
vbLf & vbLf & "Note: To Re-Show these Instructions from any sheet, Hit: Ctrl + i" & vbLf & vbLf & _
"Note: To Re-Run the ""Load Questions Utility"" Hit: Ctrl + q" & vbLf & _
"Only Sheets: Start, Info, Questions and Answers, will remain all others are deleted!" & vbLf & _
"Sheet: ""Start"" is the Main Menu Application. ""Info"" is where you add supplemental material." & _
vbLf & "All other Sheets are ""Hidden when you Hit: Ctrl + h, To show all Sheets, Hit: Ctrl + q"
Call displayAppInst
End Sub
Sub displayAppInst()
Application.MacroOptions Macro:="displayAppInst", Description:= _
"Show the Application Instructions!", ShortcutKey:="a"
MsgBox "Application Instructions:" & vbLf & _
"Use the ""Start"" Sheet to Navagate!" & vbLf & vbLf & _
"Use the ""Info"" Sheet to Add Supplemental Question: Materials and Support Information!" & vbLf & _
vbLf & "Note: To Re-Show these ""Application Instructions"" at any Time, Hit: Ctrl + a" & vbLf
End Sub
Private Sub myQsMsg()
myQResp = UCase(InputBox(myQMsg, myQTitle, myQDefault))
End Sub
Sub myDoQuestions()
Dim ArrayList()
Dim myBot&, n%, a%
Dim ArrayCnt&, ArrayNextItem&
Dim strMyName$, strDomainName$, strComputerName$, strUserName$
Dim lngNextItem&, lngRandSeed&, lngNumOfItems&, lngFirstDataRow&, lngItemCnt&
myBot = Sheets("Questions").Range("A65536").End(xlUp).Row
'Re-set results!
With Sheets("Answers")
.Visible = True
.Select
.Columns("B:B").ClearContents
.Range(Cells(myBot + 1, 1), Cells(myBot + 5, 1)).ClearContents
.Range("A1").Select
.Visible = False
End With
Sheets("Start").Select
ReDim ArrayList(myBot)
Randomize 'Get random item from list as a start!
lngRandSeed = Int((myBot * Rnd) + 1)
'Build new Array!
For lngNextItem = 1 To myBot
If lngRandSeed = myBot Then lngRandSeed = 0 'Convert list to loop!
lngRandSeed = lngRandSeed + 1
ArrayList(ArrayCnt) = lngRandSeed 'Load Array!
ArrayCnt = ArrayCnt + 1
Next lngNextItem
For ArrayNextItem = 0 To UBound(ArrayList) - 1
n = ArrayList(ArrayNextItem)
myQTitle = "Question" & n & "!"
myQMsg = Sheets("Questions").Range("A" & n).Value
myQDefault = ""
myAgain:
Call myQsMsg
If Len(myQResp) <> 1 Then
MsgBox "Your answer must be one letter!"
GoTo myAgain
End If
'Check answers!
If myQResp = UCase(Sheets("Answers").Range("A" & n).Value) Then
a = (a + 1)
Sheets("Answers").Range("B" & n).Value = n & ", Correct, you entered: " & myQResp
Else
Sheets("Answers").Range("B" & n).Value = n & ", Wrong, you entered: " & myQResp
End If
Next ArrayNextItem
strMyName = InputBox("You have completed all the exam questions!" & vbLf & vbLf & vbLf & _
"Please enter your Full Name:", "Get User-Name?", "")
MsgBox "Your Score: [ " & a & " ] Right, out of: [ " & myBot & " ] Questions!", _
vbExclamation + vbOKOnly, _
"Results!"
'Computer Information!
strDomainName = Environ("UserDomain")
strComputerName = Environ("ComputerName")
strUserName = Environ("UserName")
'Print!
With Sheets("Answers")
.Visible = True
.Select
.Columns("A:A").Select
Selection.Font.ColorIndex = 1
.Range("A" & myBot + 2).Value = "Domain: " & strDomainName & _
", Computer: " & strComputerName & _
", User: " & strUserName
.Range("A" & myBot + 3).Value = "Exam: " & Sheets("Start").Range("A3").Value
.Range("A" & myBot + 4).Value = "For: " & strMyName & ", on:" & Date & ", at: " & Time
.Range("A" & myBot + 5).Value = "Score: [ " & a & " ]: Right, out of: [ " & myBot & " ]"
.Range("A1").Select
.PrintOut
.Columns("A:A").Select
Selection.Font.ColorIndex = 2
.Range("A1").Select
.Visible = False
End With
Sheets("Start").Select
End Sub
Sub myHide()
On Error GoTo myErr
Application.MacroOptions Macro:="myHide", Description:= _
"Hide Application Data Sheets!", ShortcutKey:="h"
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Questions").Range("A1").Select
If Sheets("Questions").Visible = True Then _
Sheets("Questions").Visible = False
Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Answers").Range("A1").Select
If Sheets("Answers").Visible = True Then _
Sheets("Answers").Visible = False
Sheets("Start").Select
Sheets("Start").Range("A1").Select
GoTo myEnd
myErr:
Sheets("Answers").Visible = False
Sheets("Questions").Visible = False
MsgBox "You can only hide once!" & vbLf & vbLf & _
"You must: Ctrl + q" & vbLf & "first or Run the Macro: ""getAccess"""
myEnd:
mySw = False
End Sub
Sub getAccess()
Dim myTitle$, myMsg$, myDefault$, myPW$, myResp$, my1stRng$, myBuild%
'**** Change the PassWord Here!********************************
'****************** vvvvvvvvvvvvvv *************************************
myPassWord = "Admin" 'Note: the PW is case sensitive!
'***********************************************************************
Application.MacroOptions Macro:="getAccess", Description:= _
"Load Questions!", ShortcutKey:="q"
myTitle = "Get Access to this Application?"
myMsg = "Please type your PassWord," & vbLf & _
"to Gain Access to your Data!"
myDefault = ""
myResp = InputBox(myMsg, myTitle, myDefault)
If myResp = myPassWord Then
mySw = True
Sheets("Answers").Visible = True
Sheets("Answers").Select
Sheets("Answers").Columns("A:B").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Visible = True
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Range("A1").Select
myBuild = MsgBox("Will you be creating a new test now?", _
vbYesNo + vbQuestion + vbDefaultButton1, "Direct View!")
Sheets("Answers").Select
On Error GoTo myLoad
If myBuild = vbYes Then
my1stRng = ActiveSheet.Range("A65536").End(xlUp).Row - 7 & ":" & _
ActiveSheet.Range("A65536").End(xlUp).Row
ActiveSheet.Range(my1stRng).ClearContents
ActiveSheet.Columns("B:B").ClearContents
ActiveSheet.Range("A1").Select
myLoad:
Sheets("Start").Select
Call myLoadQuestions
Else
Sheets("Answers").Range("A1").Select
End If
Else
MsgBox "Error: Wrong PassWord!"
mySw = False
End If
End Sub
I am trying to create a multiple choice test in Excel 2010. I know nothing about programming in VBA.
I would like to thank Joe Was for his excellent contribution on creating a MCQ quiz in Excel.
I have compiled the following code from his various posts. However I have two questions:
1. The code for the print option prints two columns - the correct answers in the first column and the responses in the second column and mentions whether it is correct or wrong. To prevent the students from cheating by taking the printout and then attempt it again with the right answers, I prefer the right answers are not printed. How do I do this.
2. The printout gives the system time when the test was completed. I would like to add the start time of the test and also calculate the total time taken for the test. Please help me with the code for inserting the start time and calculating the total time taken and also please let me know where exactly I should place this portion in the original code.
Many thanks in advance.
Vijay
The code which I have compiled from earlier posts - Thanks again to Joe Was - is as below:
Public myQMsg$, myQTitle$, myQDefault$, myQResp$, myRespK$, mySw As Boolean
'*** Change your Test Title Here! ***
Public Const myTestTitle$ = "Welcome to the Test One Exam!"
'********************************************************************
Private Sub myLoadQuestions()
Dim tSht%, eSht%, tSht2%, eSht2%, tShts1%, eShts1%, tShts2%, eShts2%
Dim myMsg$, myTitle$, myDefault$, myResp$
Dim ws As Worksheet, myNewSht As Worksheet
myTitle = "Change this Tests Title?"
On Error GoTo mySkip
If Sheets("Start").Range("A3").Value <> "" Then
myDefault = Sheets("Start").Range("A3").Value
Else
mySkip:
myDefault = myTestTitle
End If
myMsg = "The current test title is:" & vbLf & vbLf & _
myDefault & vbLf & vbLf & _
"If you want to change this tests title," & vbLf & _
"do so now!"
myResp = InputBox(myMsg, myTitle, myDefault)
tSht = Worksheets.Count
For Each ws In Worksheets
eSht = eSht + 1
If ws.Name = "Start" Then GoTo gotSht
If tSht = eSht Then GoTo mkSht
Next ws
mkSht:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Start"
Sheets("Start").Move After:=Sheets(tSht + 1)
gotSht:
Sheets("Start").Select
Sheets("Start").Range("A3").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 18
End With
Sheets("Start").Range("A3").Value = myResp
On Error GoTo myAdd
If ActiveSheet.Shapes.Count = 0 Then GoTo myAdd
ActiveSheet.Shapes("myButton").Delete
myAdd:
With Sheets("Start").Shapes.AddShape(msoShapeBevel, 172, 105, 90, 33)
.Name = "myButton"
End With
ActiveSheet.Shapes("myButton").Select
With Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 26
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 18
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
ActiveSheet.Shapes("myButton").Select
Selection.Characters.Text = "Start"
With Selection.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 14
.ColorIndex = 11
End With
ActiveSheet.Shapes("myButton").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.AutoSize = False
End With
ActiveSheet.Shapes("myButton").Select
Selection.OnAction = "myDoQuestions"
Range("A1").Select
'********************************************************************
tSht2 = Worksheets.Count
For Each ws In Worksheets
eSht2 = eSht2 + 1
If ws.Name = "Info" Then GoTo gotShtB
If tSht2 = eSht2 Then GoTo mkShtB
Next ws
mkShtB:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Info"
Sheets("Info").Move After:=Sheets(tSht2 + 1)
gotShtB:
Sheets("Info").Select
Sheets("Info").Range("A1").Select
'********************************************************************
tShts1 = Worksheets.Count
For Each ws In Worksheets
eShts1 = eShts1 + 1
If ws.Name = "Questions" Then GoTo gotSht1
If tShts1 = eShts1 Then GoTo mkSht1
Next ws
mkSht1:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Questions"
Sheets("Questions").Move After:=Sheets(tShts1 + 1)
gotSht1:
If Sheets("Questions").Visible = False Then _
Sheets("Questions").Visible = True
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Columns("A:A").ColumnWidth = 128
Sheets("Questions").Range("A1").Select
'********************************************************************
tShts2 = Worksheets.Count
For Each ws In Worksheets
eShts2 = eShts2 + 1
If ws.Name = "Answers" Then GoTo gotSht2
If tShts2 = eShts2 Then GoTo mkSht2
Next ws
mkSht2:
Set myNewSht = Sheets.Add(Type:=xlWorksheet)
myNewSht.Name = "Answers"
Sheets("Answers").Move After:=Sheets(tShts2 + 1)
gotSht2:
If Sheets("Answers").Visible = False Then _
Sheets("Answers").Visible = True
Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Answers").Range("A1").Select
Sheets("Questions").Select
'********************************************************************
For Each ws In Worksheets
If ws.Name = "Start" Or ws.Name = "Info" Or ws.Name = "Questions" Or ws.Name = "Answers" Then
GoTo myNotDel
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
myNotDel:
Next ws
Call displayLoadInst
End Sub
Sub displayLoadInst()
Application.MacroOptions Macro:="displayLoadInst", Description:= _
"Show the Load Questions Instructions!", ShortcutKey:="i"
MsgBox "Instructions: Type your Questions in Column: A," & vbLf & _
"Starting in Row: 1, Cell: A1 of the Sheet Named ""Questions""" & vbLf & _
"One Question per Row-Cell!" & vbLf & vbLf & _
"Like: On Sheet ""Questions"" Cell: ""A1"" Add:" & vbLf & vbLf & _
"Select the best answer: A, B, C, D or E. [Note: For a new line in your Question, Hit: Alt + Enter]" & vbLf & _
"1 + 1 = ? [Note: For a BLANK Line in your Question, Hit: Alt + Enter, two times!]" & vbLf & vbLf & _
" A). 1.1, B). 1, C). 2, D). 4, E). None of these answers! [Note: Add Spacing as needed!] " & vbLf & _
vbLf & vbLf & "Then Add Each Question's Answer to the Same Cell on the Sheet Named: ""Answers""" & _
vbLf & vbLf & "Like for the Sample Question Above on Sheet ""Answers"" Cell: A1:" & vbLf & "C" & _
vbLf & vbLf & "Note: To Re-Show these Instructions from any sheet, Hit: Ctrl + i" & vbLf & vbLf & _
"Note: To Re-Run the ""Load Questions Utility"" Hit: Ctrl + q" & vbLf & _
"Only Sheets: Start, Info, Questions and Answers, will remain all others are deleted!" & vbLf & _
"Sheet: ""Start"" is the Main Menu Application. ""Info"" is where you add supplemental material." & _
vbLf & "All other Sheets are ""Hidden when you Hit: Ctrl + h, To show all Sheets, Hit: Ctrl + q"
Call displayAppInst
End Sub
Sub displayAppInst()
Application.MacroOptions Macro:="displayAppInst", Description:= _
"Show the Application Instructions!", ShortcutKey:="a"
MsgBox "Application Instructions:" & vbLf & _
"Use the ""Start"" Sheet to Navagate!" & vbLf & vbLf & _
"Use the ""Info"" Sheet to Add Supplemental Question: Materials and Support Information!" & vbLf & _
vbLf & "Note: To Re-Show these ""Application Instructions"" at any Time, Hit: Ctrl + a" & vbLf
End Sub
Private Sub myQsMsg()
myQResp = UCase(InputBox(myQMsg, myQTitle, myQDefault))
End Sub
Sub myDoQuestions()
Dim ArrayList()
Dim myBot&, n%, a%
Dim ArrayCnt&, ArrayNextItem&
Dim strMyName$, strDomainName$, strComputerName$, strUserName$
Dim lngNextItem&, lngRandSeed&, lngNumOfItems&, lngFirstDataRow&, lngItemCnt&
myBot = Sheets("Questions").Range("A65536").End(xlUp).Row
'Re-set results!
With Sheets("Answers")
.Visible = True
.Select
.Columns("B:B").ClearContents
.Range(Cells(myBot + 1, 1), Cells(myBot + 5, 1)).ClearContents
.Range("A1").Select
.Visible = False
End With
Sheets("Start").Select
ReDim ArrayList(myBot)
Randomize 'Get random item from list as a start!
lngRandSeed = Int((myBot * Rnd) + 1)
'Build new Array!
For lngNextItem = 1 To myBot
If lngRandSeed = myBot Then lngRandSeed = 0 'Convert list to loop!
lngRandSeed = lngRandSeed + 1
ArrayList(ArrayCnt) = lngRandSeed 'Load Array!
ArrayCnt = ArrayCnt + 1
Next lngNextItem
For ArrayNextItem = 0 To UBound(ArrayList) - 1
n = ArrayList(ArrayNextItem)
myQTitle = "Question" & n & "!"
myQMsg = Sheets("Questions").Range("A" & n).Value
myQDefault = ""
myAgain:
Call myQsMsg
If Len(myQResp) <> 1 Then
MsgBox "Your answer must be one letter!"
GoTo myAgain
End If
'Check answers!
If myQResp = UCase(Sheets("Answers").Range("A" & n).Value) Then
a = (a + 1)
Sheets("Answers").Range("B" & n).Value = n & ", Correct, you entered: " & myQResp
Else
Sheets("Answers").Range("B" & n).Value = n & ", Wrong, you entered: " & myQResp
End If
Next ArrayNextItem
strMyName = InputBox("You have completed all the exam questions!" & vbLf & vbLf & vbLf & _
"Please enter your Full Name:", "Get User-Name?", "")
MsgBox "Your Score: [ " & a & " ] Right, out of: [ " & myBot & " ] Questions!", _
vbExclamation + vbOKOnly, _
"Results!"
'Computer Information!
strDomainName = Environ("UserDomain")
strComputerName = Environ("ComputerName")
strUserName = Environ("UserName")
'Print!
With Sheets("Answers")
.Visible = True
.Select
.Columns("A:A").Select
Selection.Font.ColorIndex = 1
.Range("A" & myBot + 2).Value = "Domain: " & strDomainName & _
", Computer: " & strComputerName & _
", User: " & strUserName
.Range("A" & myBot + 3).Value = "Exam: " & Sheets("Start").Range("A3").Value
.Range("A" & myBot + 4).Value = "For: " & strMyName & ", on:" & Date & ", at: " & Time
.Range("A" & myBot + 5).Value = "Score: [ " & a & " ]: Right, out of: [ " & myBot & " ]"
.Range("A1").Select
.PrintOut
.Columns("A:A").Select
Selection.Font.ColorIndex = 2
.Range("A1").Select
.Visible = False
End With
Sheets("Start").Select
End Sub
Sub myHide()
On Error GoTo myErr
Application.MacroOptions Macro:="myHide", Description:= _
"Hide Application Data Sheets!", ShortcutKey:="h"
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Questions").Range("A1").Select
If Sheets("Questions").Visible = True Then _
Sheets("Questions").Visible = False
Sheets("Answers").Select
Sheets("Answers").Columns("A:A").Select
Selection.Font.ColorIndex = 2
Sheets("Answers").Range("A1").Select
If Sheets("Answers").Visible = True Then _
Sheets("Answers").Visible = False
Sheets("Start").Select
Sheets("Start").Range("A1").Select
GoTo myEnd
myErr:
Sheets("Answers").Visible = False
Sheets("Questions").Visible = False
MsgBox "You can only hide once!" & vbLf & vbLf & _
"You must: Ctrl + q" & vbLf & "first or Run the Macro: ""getAccess"""
myEnd:
mySw = False
End Sub
Sub getAccess()
Dim myTitle$, myMsg$, myDefault$, myPW$, myResp$, my1stRng$, myBuild%
'**** Change the PassWord Here!********************************
'****************** vvvvvvvvvvvvvv *************************************
myPassWord = "Admin" 'Note: the PW is case sensitive!
'***********************************************************************
Application.MacroOptions Macro:="getAccess", Description:= _
"Load Questions!", ShortcutKey:="q"
myTitle = "Get Access to this Application?"
myMsg = "Please type your PassWord," & vbLf & _
"to Gain Access to your Data!"
myDefault = ""
myResp = InputBox(myMsg, myTitle, myDefault)
If myResp = myPassWord Then
mySw = True
Sheets("Answers").Visible = True
Sheets("Answers").Select
Sheets("Answers").Columns("A:B").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Visible = True
Sheets("Questions").Select
Sheets("Questions").Columns("A:A").Select
Selection.Font.ColorIndex = 0
Sheets("Questions").Range("A1").Select
myBuild = MsgBox("Will you be creating a new test now?", _
vbYesNo + vbQuestion + vbDefaultButton1, "Direct View!")
Sheets("Answers").Select
On Error GoTo myLoad
If myBuild = vbYes Then
my1stRng = ActiveSheet.Range("A65536").End(xlUp).Row - 7 & ":" & _
ActiveSheet.Range("A65536").End(xlUp).Row
ActiveSheet.Range(my1stRng).ClearContents
ActiveSheet.Columns("B:B").ClearContents
ActiveSheet.Range("A1").Select
myLoad:
Sheets("Start").Select
Call myLoadQuestions
Else
Sheets("Answers").Range("A1").Select
End If
Else
MsgBox "Error: Wrong PassWord!"
mySw = False
End If
End Sub
