Inter Macro
I didn't have time to test changes. Last time I fully tested the code before
posting. I now made 3 macros. One to create the questions. So now you can
run the new macro to generate the questions. Then have users run the test.
A new user will be assigned one of the sets of random questions previously
created.
Const Questions = 50
Const QuestSht = "Questions"
Const StatSht = "Status"
Sub TakeTest()
'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
If .Range("E" & UserRow) = "" Then
MsgBox ("No More Random Questions - Exit Macro")
Exit Sub
End If
.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
CurrentQuestion = 1
.Range("B" & UserRow) = Questions
.Range("C" & UserRow) = CurrentQuestion
Else
CurrentQuestion = .Range("C" & UserRow) + 1
End If
End With
NumberofQuestions = Questions
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
If Sheets(StatSht).Range("C" & UserRow) Questions Then
Sheets(StatSht).Range("C" & UserRow) = "Completed"
End If
ThisWorkbook.Save
End Sub
Sub MakeQuestions()
Dim SortArray(Questions, 2)
With Sheets(StatSht)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
RowCount = LastRow + 1
End With
'Randomly choose 12 , 16, 24
Quest = Int(3 * Rnd())
Select Case Quest
Case 0: NumberofTests = 12
Case 1: NumberofTests = 16
Case 2: NumberofTests = 24
End Select
For TestNumber = 1 To NumberofTests
'create numbers questions
For i = 1 To Questions
SortArray(i, 1) = i
SortArray(i, 2) = Rnd()
Next i
'sort array to get random question
For i = 1 To Questions
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
With Sheets(StatSht)
'Save numbers in worksheet
.Range("E" & RowCount).Offset(0, i - 1) = _
SortArray(i, 1)
End With
Next i
RowCount = RowCount + 1
Next TestNumber
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" wrote:
Joel wrote two codes that are really good which I posted below. I am
trying to understand how to adjust the take test code below so that it will
randomly ask all 50 questions 12, 16, or 24 times or just 12 times if that's
easier to do while keeping a record of each answer that is given. In other
words I am trying to ask all 50 questions randomly at least 12 times each.
Currently the code is randomly selecting 12, 16, or 24 and asking 12, 16, or
24 of the 50 questions one time. Any thoughts?
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
|