Inter Macro

T

TGalin

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
 
J

Joel

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
 
T

TGalin

Joel. Thank you this is very good. I am not sure if I made a mistake, but
when I try to run the Make Questions Macro I get a message that reads
"Compile Error: Constant Expression Required." and the part that reads
questions in the code "Dim SortArray(Questions, 2)" gets highlighted in blue.
I tried changing the Questions to Quest but I got the same result. Any
ideas?
 
J

Joel

I had a couple of small problems with the macro MakeQuestions()

Sub MakeQuestions()

Dim SortArray(Questions, 2)

With Sheets(StatSht)
LastRow = .Range("E" & 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

Sheets(StatSht).Range("B" & RowCount) = Questions

'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
 
T

TGalin

Thank you for your feedback. The macros you have written are remarkable. I
also appreciate very much you're help. I may have made a mistake, I think
the posted code might be the same after I tried to read them. Also I noticed
I am getting the same message when I run the macro MakeQuestions. The
message is "Compile Error: Constant Expression Required." Then this part of
the code "Dim SortArray(Questions, 2)" the part that says Questions gets
highlighted in blue. Any thoughts?
Also is this code below helpful at all to the MakeQuestions macro? Another
community member recommended it and although I messed around with it I was
not able to get the result I am after.

Sub TestUniqueRandomNumbers()
Dim varrRandomNumberList As Variant
varrRandomNumberList = UniqueRandomNumbers(50, 1, 50)
Range(Cells(3, 1), Cells(50 + 2, 1)).Value = _
Application.Transpose(varrRandomNumberList)
End Sub
 
J

Joel

You lost the definition of questions

Const Questions = 50.

I don't know what UniqueRandomNumbers() is?
 
T

TGalin

I ran the Sub MakeQuestions() and got a Run-time error '9':Subscript out of
range. If I click debug "With Sheets(StatSht)" in the code gets highlighted
in yellow. If I click on the "With Sheets" part a small box appears that
reads "Sheets(StatSht)=<Subscription out of range>, In addition if I click on
the (StatSht) part of the yellow code that is highlighted I get a message
that reads "StatSht=Empty"


So I tried to change With Sheets(StatSht) to With Sheets(Questions) the
three times it appears in the Sub MakeQuestions() then I think the code is
working but it's putting the data on worksheet Quest 48. I suspect what's on
Quest 48 is supposed to go onto the Status Sheet. I think that might be the
case because when I run Sub TakeTest() I get a message that says "No More
Random Questions-Exit Macro". What do you think?
 
J

Joel

There was no problems with the code. I reposted the last code below. You
need to start with two worksheets (Status, and Questions). The Questions are
on the Question worksheet B4 to B53. Run CreateWorksheets first., then
MakeQuestions(), and finally run TakeTest.


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("E" & 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

Sheets(StatSht).Range("B" & RowCount) = Questions

'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
 
T

TGalin

You're right. After I read this post, I opened a new workbook, opened a new
module in VB and pasted it right in. I think I was having problems because I
kept deleting the original codes and putting the new ones in. Something
about doing that seems to have created problems. My apologies, I feel
stupid.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Interactive Code2 5
Adjusting a Macro 10
Copy part of text file 4
chart MAcro to change on activecell 0
Macro to Combine Data from Multiple Sheets with Cell References 4
Macro to delete row if cells greater than certain value 1
this code is VERY slow, is it the code or perhaps a worksheet issue 32
type mismatch error in macro in excel 0

Top