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