Inter Macro
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 |
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 |
Inter Macro
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? "Joel" wrote: 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 |
Inter Macro
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 "TGalin" wrote: 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? "Joel" wrote: 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 |
Inter Macro
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 "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: 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 |
Inter Macro
You lost the definition of questions
Const Questions = 50. I don't know what UniqueRandomNumbers() is? "TGalin" wrote: 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 "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: 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 |
Inter Macro
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? "Joel" wrote: You lost the definition of questions Const Questions = 50. I don't know what UniqueRandomNumbers() is? "TGalin" wrote: 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 "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: 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 |
Inter Macro
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 "TGalin" wrote: 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? "Joel" wrote: You lost the definition of questions Const Questions = 50. I don't know what UniqueRandomNumbers() is? "TGalin" wrote: 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 "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: 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) |
Inter Macro
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. On the bright side, this macro is amazing. Thank you very much for you're help. "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: You lost the definition of questions Const Questions = 50. I don't know what UniqueRandomNumbers() is? "TGalin" wrote: 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 "Joel" wrote: 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 "TGalin" wrote: 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? "Joel" wrote: 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 |
All times are GMT +1. The time now is 03:12 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com