Interactive Code2
 

Joel wrote two codes that are really good which I posted below. I am still
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

Interactive Code2
 

Are you trying to say that you want to ask all 50 question each time for 12,
16 or 24 times with the question being reshuffled in random order each time?



"TGalin" wrote:

Joel wrote two codes that are really good which I posted below. I am still
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

Interactive Code2
 

This is from the net by Erlandsen Data Consulting. You can generate fifty
unique numbers in random order by runing the small macro at the bottom. It
lists the numbers in column A cells 3 thru 52, but you can modify the display
range to suit your purposes. This can be adapted to then call the list of
questions in the same order.

Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, _
ULimit As Long) As Variant
' creates an array with NumCount unique long random numbers in the range
LLimit - ULimit (including)
Dim RandColl As Collection, i As Long, varTemp() As Long
UniqueRandomNumbers = False
If NumCount < 1 Then Exit Function
If LLimit ULimit Then Exit Function
If NumCount (ULimit - LLimit + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (ULimit - LLimit) + LLimit)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = NumCount
ReDim varTemp(1 To NumCount)
For i = 1 To NumCount
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
End Function


' example use:

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




"TGalin" wrote:

Joel wrote two codes that are really good which I posted below. I am still
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

Interactive Code2
 

Exactly! You hit the nail on the head.

"JLGWhiz" wrote:

Are you trying to say that you want to ask all 50 question each time for 12,
16 or 24 times with the question being reshuffled in random order each time?



"TGalin" wrote:

Joel wrote two codes that are really good which I posted below. I am still
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

Interactive Code2
 

Do you know where TestUniqueRandomNumbers would fit in Sub TakeTest? Also
the questions in my doc are in Column B. I am not sure how to change
TestUniqueRandomNumbers so that it searches column B, I couldn't figure out
which part represents Column A. What do you think?

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




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


"JLGWhiz" wrote:


This is from the net by Erlandsen Data Consulting. You can generate fifty
unique numbers in random order by runing the small macro at the bottom. It
lists the numbers in column A cells 3 thru 52, but you can modify the display
range to suit your purposes. This can be adapted to then call the list of
questions in the same order.

Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, _
ULimit As Long) As Variant
' creates an array with NumCount unique long random numbers in the range
LLimit - ULimit (including)
Dim RandColl As Collection, i As Long, varTemp() As Long
UniqueRandomNumbers = False
If NumCount < 1 Then Exit Function
If LLimit ULimit Then Exit Function
If NumCount (ULimit - LLimit + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (ULimit - LLimit) + LLimit)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = NumCount
ReDim varTemp(1 To NumCount)
For i = 1 To NumCount
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
End Function


' example use:

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




"TGalin" wrote:

Joel wrote two codes that are really good which I posted below. I am still
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

Interactive Code2
 

Hello,

I suggest to take my UDF VBUniqRandInt which even offers the feature
to allow for repetitions (in case a question is allowed to reappear
before all others have been stated):
http://www.sulprobil.com/html/uniqrandint.html

Regards,
Bernd