Macro Interactive Code on Excel Worksheet

July 21, 2009 by vba excel
Filed under: Excel Vba, Excel Worksheet

Sponsor

Excel Vba Macro Interactive Code on Excel Worksheet [Q]

I have a workbook with one worksheet. The worksheet has a list of 50
questions ranging from B4:B54. I am looking for a code that will select each question randomly, arbitrarily choose 12, 16, or 24, and take these steps below while asking each question that many times (12, 16, or 24).

1) Open a message box with the question and a field for an answer. After the user gives an answer and presses enter…..

2) A new worksheet get created for that question, and a copy of the question is pasted into excel C2 cell of that new excel worksheet along with each answer that was given for the question that was asked. (The macro does not jump to the new excel worksheets that are created but it keeps a record of everything that is asked and answered so when the macro is finished all questions and answers can be reviewed.

3) At any point, the user is able to hit esc or some other keyboard command so that the excel vba macro stops at that point, without losing any of the data entered so far, and when restarted later the macro can resume the process from where it left off.

Excel Vba Macro Interactive Code on Excel Worksheet [A]

The excel vba macro solution is to have a hidden excel worksheet which contains the history information on all users. The history worksheet will have the user name in column A. the status in Colum 2 (question number of complete), The last question answered in Column C

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

My code assumes two worksheets
1) Questions
2) Status - History of users

Last question is on B53 (not B54)

I created two macros. One to create response sheets and one to ask questions.

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