Interactive Code

[TGalin]

I have a workbook with one worksheet. The worksheet has a list of 50
questions ranging from B4:B54. I am looking for a code that will select each
question randomly, arbitrarily choose 12, 16, or 24, and take these steps
below while asking each question that many times (12, 16, or 24).

1) Open a message box with the question and a field for an answer. After
the user gives an answer and presses enter…..

2) A new worksheet get created for that question, and a copy of the question
is pasted into C2 of that new worksheet along with each answer that was given
for the question that was asked. (The macro does not jump to the new
worksheets that are created but it keeps a record of everything that is asked
and answered so when the macro is finished all questions and answers can be
reviewed.

3) At any point, the user is able to hit esc or some other keyboard command
so that the macro stops at that point, without losing any of the data
entered so far, and when restarted later the macro can resume the process
from where it left off.

 

[Joel]

I've read this posting when it was posted earlier in the week. The problem I
was having is how to save the result so you can continue. I think the
solution is to have a hidden worksheet which contains the history information
on all users. The history worksheet will have the user name in column A. the
status in Colum 2 (question number of complete), The last question answered
in Column C

'Status sheet info
' Column A (User Name)
' Column B (Number of questions Selected)
' Column C (Last Question Number or completed)
' Column E+ (the list of random numbers)


My code assumes two worksheets
1) Questions
2) Status - History of users

Last question is on B53 (not B54)

I created two macros. One to create response sheets and one to ask questions.

Const Questions = 50
Const QuestSht = "Questions"
Const StatSht = "Status"

Sub TakeTest()

Dim SortArray(Questions, 2)

'Status sheet info
' Column A (User Name)
' Column B (Number of questions Selected)
' Column C (Last Question Number or completed)
' Column E+ (the list of random numbers)

'get user name
User = Environ("UserName")
With Sheets(StatSht)
'find user
Set c = .Columns("A").Find(what:=User, LookIn:=xlValues, _
lookat:=xlWhole)
If c Is Nothing Then
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
UserRow = LastRow + 1
.Range("A" & UserRow) = User
NewUser = True
Else
UserRow = c.Row
If .Range("C" & UserRow) = "Completed" Then
NewUser = True
Else
NewUser = False
End If
End If

If NewUser = True Then
Randomize
'Randomly choose 12 , 16, 24
Quest = Int(3 * Rnd())
Select Case Quest
Case 0: NumberofQuestions = 12
Case 1: NumberofQuestions = 16
Case 2: NumberofQuestions = 24
End Select

CurrentQuestion = 1

'create numbers questions
For i = 1 To 50
SortArray(i, 1) = i
SortArray(i, 2) = Rnd()
Next i

'sort array to get random question
For i = 1 To NumberofQuestions
For j = i To Questions
If SortArray(j, 2) < SortArray(i, 2) Then
Temp = SortArray(i, 1)
SortArray(i, 1) = SortArray(j, 1)
SortArray(j, 1) = Temp

Temp = SortArray(i, 2)
SortArray(i, 2) = SortArray(j, 2)
SortArray(j, 2) = Temp

End If
Next j
'Save numbers in worksheet
.Range("E" & UserRow).Offset(0, i - 1) = _
SortArray(i, 1)
Next i

.Range("B" & UserRow) = NumberofQuestions
.Range("C" & UserRow) = CurrentQuestion
Else
NumberofQuestions = .Range("B" & UserRow)
CurrentQuestion = .Range("C" & UserRow) + 1
End If
End With

For QuestionCount = CurrentQuestion To NumberofQuestions
QuestionNumber = _
Sheets(StatSht).Range("E" & UserRow) _
.Offset(0, QuestionCount - 1)

Set QSht = Sheets("Quest " & QuestionNumber)

MyTitle = "Question Count = " & QuestionCount & " of " & _
NumberofQuestions & " " & _
"Survey Item " & _
QuestionNumber

With QSht
MyPrompt = .Range("A1")

Response = InputBox(prompt:=MyPrompt, _
Title:=MyTitle)


LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
.Range("A" & NewRow) = User
.Range("B" & NewRow) = Response

Sheets(StatSht).Range("C" & UserRow) = QuestionCount + 1

Response = MsgBox(prompt:="End test", Buttons:=vbYesNo)
If Response = vbYes Then
Exit For
End If
End With

ThisWorkbook.Save
Next QuestionCount
ThisWorkbook.Save

End Sub
Sub CreateWorksheets()
With Sheets(QuestSht)
For QuestNumber = 1 To Questions
Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = "Quest " & QuestNumber
NewSht.Range("A1") = .Range("B4").Offset(QuestNumber - 1, 0)
NewSht.Range("A2") = "User"
NewSht.Range("B2") = "Response"
Next QuestNumber
End With
End Sub

 

[TGalin]

This is quite possibly the most amazing thing I have ever seen. Thank you!
It works better than I could have ever imagined.

 

[TGalin]

I have been using both macros a lot and I noticed the take tests macro will
ask 12 of the 50 questions and then stop. Afterwards, if I try to run the
take tests macro again it just saves the workbook. Is there any way to
adjust the code so that it will ask all 50 questions 12, 16, or 24 times? or
just 12 times if that's more practical? My main goal is to cover all 50
questions at least 12 times.

I am also wondering what part of the code should I change if I want to
change the number of questions from 50 to 70 or 50 to 20 or 50 to all of
Column B? Thank you for your help.

 

[TGalin]

I figured out how to change the number of questions from 50 to 70 or 50 to
20, etc.

The only thing I am still try to understand is how to adjust the take tests
macro so that it will ask all 50 questions 12, 16, or 24 times or just 12
times if that's more practical while keeping a record of each answer that is
given. My main goal is to cover all 50 questions at least 12 times. Any
thoughts?