Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
inter-dependency | Excel Worksheet Functions | |||
Inter sheet call ups | Excel Discussion (Misc queries) | |||
Inter data into a cell | Excel Programming | |||
[email protected] | Excel Discussion (Misc queries) | |||
Inter-process handling | Excel Programming |