How to scramble tables in word

[amit81]

Hello Friends

I am working on a question bank having more than 500 questions in a word file.
For Each question a table is created with seven rows.
So for 500 questions we have created 500 tables.

I want to scramble the tables (questions) i.e. I want to randomly shuffle each table (question).

Kindly guide how to do this using VBA Macro.

[Kilroy]

I found this macro on "WordBanter.com" http://www.wordbanter.com/showthread.php?t=49126 It doesn't quite work. I posted a reply to the thread stating it didn't work. For me it only deletes the first column but I believe it can be modified.


Sub ShuffleQuestions()
Dim Tmax As Integer
Dim strCell As String
Dim strQ As Variant
Dim strText As String
Dim I As Integer
Dim Z As Integer
Dim intQsLeft As Integer
Dim rndQ As Integer
Dim Q As Integer
Dim vArray As Variant
Set objDict = CreateObject("Scripting.Dictionary")
Tmax = ThisDocument.Tables(1).Rows.Count
For I = 1 To Tmax
strCell = ThisDocument.Tables(1).Cell(I, 1).Range.Text
strQ = Left(strCell, Len(strCell) - 1)
objDict.Add strQ, strQ
Next I
ReDim arrQs(I - 1)
intQsLeft = I - 2
Z = 0

Do While intQsLeft = 0
Randomize
rndQ = Int((intQsLeft + 1) * Rnd)
intQsLeft = intQsLeft - 1
vArray = objDict.Items
strText = vArray(rndQ)
arrQs(Q) = strText
Z = Z + 1
objDict.Remove strText
Loop
For Q = 1 To Tmax
ThisDocument.Tables(1).Cell(Q, 1).Range.Text = arrQs(Q - 1)
Next Q

End Sub

[amit81]

Thank you Kilroy for helping. The above code is not working and showing some kind of error.
I think the above code is for scrambling rows of a table.

I am looking for randomizing the tables in a word document.

[gmaxey]

Maybe something like this:


Option Explicit
Sub Test()
Dim oRng As Range
Dim lngCount As Long, lngIndex As Long
Dim varRanNums
lngCount = ActiveDocument.Tables.Count
varRanNums = fcnRandomNonRepeatingNumberGenerator(1, lngCount, lngCount, False)
For lngIndex = 1 To UBound(varRanNums)
Set oRng = ActiveDocument.Range
oRng.Collapse wdCollapseEnd
oRng.InsertBefore vbCr
oRng.Collapse wdCollapseEnd
ActiveDocument.Tables(varRanNums(lngIndex)).Range.Copy
oRng.Paste
Next
For lngIndex = lngCount To 1 Step -1
Set oRng = ActiveDocument.Tables(lngIndex).Range
ActiveDocument.Tables(lngIndex).Delete
oRng.Paragraphs(1).Range.Delete
Next
lbl_Exit:
Exit Sub
End Sub
Function fcnRandomNonRepeatingNumberGenerator(LowerNumber As Long, UpperNumber As Long, _
NumRange As Long, _
Optional bSort As Boolean = False) As Variant
Dim lngNumbers As Long, lngRandom As Long, lngTemp As Long
ReDim varNumbers(LowerNumber To UpperNumber) As Variant
Dim varRandomNumbers() As Variant

For lngNumbers = LowerNumber To UpperNumber
varNumbers(lngNumbers) = lngNumbers
Next lngNumbers
Randomize
For lngNumbers = 1 To NumRange
lngRandom = Int(Rnd() * (UpperNumber - LowerNumber + 1 - (lngNumbers - 1))) + (LowerNumber + (lngNumbers - 1))
lngTemp = varNumbers(lngRandom)
varNumbers(lngRandom) = varNumbers(LowerNumber + lngNumbers - 1)
varNumbers(LowerNumber + lngNumbers - 1) = lngTemp
Next lngNumbers
ReDim Preserve varNumbers(LowerNumber To LowerNumber + NumRange - 1)
ReDim varRandomNumbers(1 To NumRange)
For lngNumbers = 1 To NumRange
varRandomNumbers(lngNumbers) = varNumbers(LBound(varNumbers) + lngNumbers - 1)
Next lngNumbers
If bSort = True Then
fcnRandomNonRepeatingNumberGenerator = ArrayListSort(varRandomNumbers())
Else
fcnRandomNonRepeatingNumberGenerator = varRandomNumbers()
End If
lbl_Exit:
Exit Function
End Function

Function ArrayListSort(varList As Variant, Optional bAscending As Boolean = True)
Dim varLE As Variant

With CreateObject("System.Collections.ArrayList")
For Each varLE In varList
.Add varLE
Next
.Sort 'Sort ascendending
If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
ArrayListSort = .Toarray()
End With
End Function

[mana]

Option Explicit

Sub test()
Dim dic As Object, dicDup As Object, rn As Object
Dim doc As Document, dup As Document
Dim k As Long, n As Long
Dim tbl As Table

Set dic = CreateObject("scripting.dictionary")
Set dicDup = CreateObject("scripting.dictionary")
Set rn = CreateObject("system.random")

Application.ScreenUpdating = False

Set doc = ActiveDocument
Set dup = Documents.Add(doc.FullName)

For k = 1 To doc.Tables.Count
Set dic(k) = doc.Tables(k)
Set dicDup(k) = dup.Tables(k)
Next

For k = 1 To dicDup.Count - 1
n = rn.next_2(k, dicDup.Count + 1)
Set tbl = dicDup(k)
Set dicDup(k) = dicDup(n)
Set dicDup(n) = tbl
Next

For k = 1 To dic.Count
dicDup(k).Range.Copy
dic(k).Range.Select
dic(k).Delete
Selection.Range.Paste
Next

dup.Close False


End Sub



マナ

[mana]

Sub test2()
Dim dic As Object, rn As Object
Dim doc As Document, dup As Document
Dim k As Long, n As Long
Dim tbl As Table

Set dic = CreateObject("scripting.dictionary")
Set rn = CreateObject("system.random")

Application.ScreenUpdating = False

Set doc = ActiveDocument
Set dup = Documents.Add(doc.FullName)

For k = 1 To doc.Tables.Count
Set dic(k) = dup.Tables(k)
Next

For k = 1 To dic.Count - 1
n = rn.next_2(k, dic.Count + 1)
Set tbl = dic(k)
Set dic(k) = dic(n)
Set dic(n) = tbl
Next

For k = 1 To dic.Count
dic(k).Range.Copy
doc.Tables(k).Range.Select
doc.Tables(k).Delete
Selection.Range.Paste
Next

dup.Close False

End Sub






Umm...this is same as post #4



Sub test3()
Dim dic As Object, rn As Object
Dim doc As Document, dup As Document
Dim k As Long, n As Long

Set dic = CreateObject("scripting.dictionary")
Set rn = CreateObject("system.random")

Application.ScreenUpdating = False

Set doc = ActiveDocument
Set dup = Documents.Add(doc.FullName)

Do
n = rn.next_2(1, doc.Tables.Count + 1)
dic(n) = Empty
If dic.Count = doc.Tables.Count Then Exit Do
Loop

For k = 1 To dic.Count
dup.Tables(dic.keys()(k - 1)).Range.Copy
doc.Tables(k).Range.Select
doc.Tables(k).Delete
Selection.Range.Paste
Next

dup.Close False

End Sub

マナ

[gmaxey]

mana,

Thanks for posting. It seems we both were initially duped thinks that the tables would have to be duplicated in some manner. Turns out not to be the case. This adaptation of your dictionary and random processes is much faster:


Sub test5()
Dim oDic As Object, oRanNumGen As Object
Dim lngIndex As Long, lngRandom As Long
Dim lngCount As Long
Dim oRng As Range, oRng2 As Range
Dim oTbls As Tables

Set oTbls = ActiveDocument.Tables
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
Application.ScreenUpdating = False
lngCount = oTbls.Count
Do
lngRandom = oRanNumGen.next_2(1, lngCount + 1)
oDic(lngRandom) = Empty
If oDic.Count = lngCount Then Exit Do
Loop
For lngIndex = 1 To oDic.Count
Set oRng = oTbls(oDic.keys()(lngIndex - 1)).Range
Set oRng2 = oTbls(lngIndex).Range
If Not oRng = oRng2 Then
oRng2.Tables(1).Delete
oRng2.FormattedText = oRng.FormattedText
End If
Next
lbl_Exit:
Set oTbls = Nothing: Set oRng = Nothing: Set oRng2 = Nothing
Set oDic = Nothing: Set oRanNumGen = Nothing
Exit Sub
End Sub


Where can I read up about system.random? I found an article but it didn't include the next_2 method. Also, what does dic(n) = Empty really do?

[mana]

> but it didn't include the next_2 method


we can't use same name,even if it is different count of parameters


Please try



Sub test()
Dim a As Object

Set a = CreateObject("system.collections.arraylist")

a.Add 1
a.Add 2
a.Add 3
a.Add 4

MsgBox a(0)

a.Reverse
MsgBox a(0)

' a.Reverse 0, 2 '<---error
a.Reverse_2 0, 2 '<---replace name with "xxx_number"
MsgBox a(0)

End Sub


Sub test2()
Dim r As Object

Set r = CreateObject("system.random")

' MsgBox r.Next(2, 10) '<---error
MsgBox r.Next_2(2, 10)

' MsgBox r.Next(10) '<---error
MsgBox r.Next_3(10)

End Sub

[mana]

> It seems we both were initially duped thinks that the tables would have to be duplicated in some manner. Turns out not to be the case.

I don't think so.
Please try document containing 3 tables.

[gmaxey]

mana,

Yes, you are correct. This should resolve that and still much faster than select, copy, paste:


Sub test5()
Dim oDic As Object, oRanNumGen As Object
Dim lngIndex As Long, lngRandom As Long
Dim lngCount As Long
Dim oRng As Range, oRng2 As Range
Dim oTbls As Tables, oTblsDup As Tables
Dim oDocDup As Document

Set oTbls = ActiveDocument.Tables
Set oDocDup = Documents.Add(ActiveDocument.FullName)
Set oTblsDup = oDocDup.Tables
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
Application.ScreenUpdating = False
lngCount = oTbls.Count
Do
lngRandom = oRanNumGen.next_2(1, lngCount + 1)
oDic(lngRandom) = Empty
If oDic.Count = lngCount Then Exit Do
Loop
For lngIndex = 1 To oDic.Count
Set oRng = oTblsDup(oDic.keys()(lngIndex - 1)).Range
'oRng.End = oRng.End + 1
Set oRng2 = oTbls(lngIndex).Range
oRng2.Tables(1).Delete
oRng2.FormattedText = oRng.FormattedText
Next
oDocDup.Close wdDoNotSaveChanges
lbl_Exit:
Set oTbls = Nothing: Set oRng = Nothing: Set oRng2 = Nothing
Set oDocDup = Nothing: oDic = Nothing: Set oRanNumGen = Nothing
Exit Sub
End Sub

[mana]

> oRng2.FormattedText = oRng.FormattedText


Oh,thank you! I couldn't do it!
It's exactly what I wanted to know.

[Kilroy]

Greg, Mana thanks for your efforts on this one. Very interesting.

[gmaxey]

Kilroy,

Yes. It was interesting. In fact, I've played around with the concept a little and decided to start with Test Bank.docm file containing 500 (or any number of questions) and and a Test Generator template with code to generate a test with a user defined number of questions drawn randomly from the test bank.

Here is the code (for simplicity, the code required the Test Bank.docm and Test Generator.dotm files to be located in same folder).

Maybe mana will come back showing how to do the same thing with the system.random. I can't find any information for working with it to say return 100 random out of a possible 500.



Option Explicit

Sub CreateTest()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oRng As Range, oRngInsert As Range
Dim lngCount As Long, lngIndex As Long, lngQuestions As Long
Dim varRanNums
Dim oFld As Field

Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
Set oBankTbls = oDocBank.Tables
Application.ScreenUpdating = False
lngCount = oBankTbls.Count
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
varRanNums = fcnRandomNonRepeatingNumberGenerator(1, lngCount, lngQuestions)
Application.ScreenUpdating = False
For lngIndex = 1 To UBound(varRanNums)
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(varRanNums(lngIndex)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert

Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
ActiveDocument.Fields.Update
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


Function fcnRandomNonRepeatingNumberGenerator(LowerNumber As Long, UpperNumber As Long, _
NumRange As Long) As Variant
Dim lngNumbers As Long, lngRandom As Long, lngTemp As Long
ReDim varNumbers(LowerNumber To UpperNumber) As Variant
Dim varRandomNumbers() As Variant

For lngNumbers = LowerNumber To UpperNumber
varNumbers(lngNumbers) = lngNumbers
Next lngNumbers
Randomize
For lngNumbers = 1 To NumRange
lngRandom = Int(Rnd() * (UpperNumber - LowerNumber + 1 - (lngNumbers - 1))) + (LowerNumber + (lngNumbers - 1))
lngTemp = varNumbers(lngRandom)
varNumbers(lngRandom) = varNumbers(LowerNumber + lngNumbers - 1)
varNumbers(LowerNumber + lngNumbers - 1) = lngTemp
Next lngNumbers
ReDim Preserve varNumbers(LowerNumber To LowerNumber + NumRange - 1)
ReDim varRandomNumbers(1 To NumRange)
For lngNumbers = 1 To NumRange
varRandomNumbers(lngNumbers) = varNumbers(LBound(varNumbers) + lngNumbers - 1)
Next lngNumbers
fcnRandomNonRepeatingNumberGenerator = varRandomNumbers
lbl_Exit:
Exit Function
End Function

Sub ClearQuestions()
Dim lngIndex As Long
Dim oRng As Range
For lngIndex = ActiveDocument.Tables.Count To 1 Step -1
Set oRng = ActiveDocument.Tables(lngIndex).Range.Paragraphs(1).Range
ActiveDocument.Tables(lngIndex).Delete
oRng.Delete
Next
End Sub

[gmaxey]

Actually, it was easier than I expected:


Sub CreateTest()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field

Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
Set oBankTbls = oDocBank.Tables
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
Do
lngIndex = oRanNumGen.next_2(1, oBankTbls.Count)
oDic(lngIndex) = Empty
If oDic.Count = lngQuestions Then Exit Do
Loop
Application.ScreenUpdating = False
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Application.ScreenUpdating = True
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub

[Kilroy]

Greg Thankyou so much for your efforts. The “next_2” wasn’t something I heard of. As you know I’ve been learning part time for a couple of years only. I was trying to read a bit about it and couldn’t really find much of an explanation for alayman other than:
Next method:Returns a random number greater than or equal to 0.
Next_2method: Returns a random number within the specified range.
Next_3method: Returns a random number greater than or equal to 0 that is less thanthe specified maximum value.
NextDoublemethod: Returns a random number between 0.0 and 1.0.


I’ll be honest I still don’t reallyunderstand it enough to try and work with it. I’m wondering if the choosing ofthe questions could be based on the sections of the document instead of alltables in the document? So if I added questions in 20 sections could this workto randomly take a number of questions from each section? So if I entered 100in the input box could it go and take 5 questions randomly from each of the 20 sections?If it could I suppose there would need to be a handler of some sort in casethere was less than the average calculated to take from each section like forexample: “If section X has less than the 100\20 then add the difference toother sections so the total is still 100 questions”?

[gmaxey]

Kilroy,

Thanks for that. Well, I took the test bank I posted the other day and divided it into 5 sections with 100 tables (questions) per section. Then using this revised code, I was able to generate a 100 question test with 20 questions from each section:


Sub CreateTestAdv()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long

'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
For lngSec = 1 To oDocBank.Sections.Count
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh)
oDic(lngIndex) = Empty
If oDic.Count = lngQuestions Then Exit Do
If lngQuestions / oDic.Count = oDocBank.Sections.Count / lngSec Then Exit Do
Loop
Next lngSec
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


There would need to be some extensive revisions to prevent errors. For example, you can't create a 500 question exam or a say a 13 question exam, but 100, 50, 25, 10 etc. are possible.

[Paul_Hossler]

Interesting, esp the part about System. I'll have to learn some more about that

Couple of comments (I think I did it right)

1. Changed one line



'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ActiveDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)



2. Added 2 References (System and Scripting). I was surprised they weren't referenced automatically (Late binding??)

3. If you wanted to 'polish' some more

a. you could write the selected test questions to a third macro-less docx (leave the 'master' docm as it) which was formatted for each class, semester, prof name, etc.
b. Add ability for different TestBank.docm to be selected and used

[Kilroy]

Ok my test bank document is 250 questions, 12 sections and I chose 25 questions. I'm getting an infinite loop:


Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh)
oDic(lngIndex) = Empty
If oDic.Count = lngQuestions Then Exit Do
If lngQuestions / oDic.Count = oDocBank.Sections.Count / lngSec Then Exit Do
Loop

Update: I've changed the mount of questions in test bank and sections and tried different amounts of questions for the exam page and nothing has changed. Still in infinite loop

[gmaxey]

Kilroy,

In my example, this condition:
If lngQuestions / oDic.Count = oDocBank.Sections.Count / lngSec Then Exit Do

was met after 20 random numbers were selected from 1-100, 40 random numbers 101-200 etc. So after all five section were processed 100 random numbers have been selected 1-500.

In your case the defined conditions are not met. I think if you tried for 24 questions then it might work.

[gmaxey]

Kilroy,

Try this. I think in your case you will get 2 questions from sections 1-11 and 3 questions from section 12.


Sub CreateTestAdv()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngLastBank As Long
'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) > 0.5 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
lngLastBank = lngQuestions - (lngPerBank * (oDocBank.Sections.Count - 1))
For lngSec = 1 To oDocBank.Sections.Count
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh)
oDic(lngIndex) = Empty
If lngSec < oDocBank.Sections.Count Then
If oDic.Count = lngPerBank * lngSec Then Exit Do
Else
If oDic.Count = lngQuestions Then Exit Do
End If
Loop
Next lngSec
Stop
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub

[Kilroy]

Greg works really well. Any multiple of the total amount of section no problem. 60 no issues, 63 choked it up, 73 no issues, 70 choked it up.

[gmaxey]

Kilroy,

Hmm. I created a test bank document (attached) with 250 questions (twenty in sections 1-11 and ten in section 12). Ran the code posted previous and tested with 60, 63, 70 and 73 and all ran fine.

However, I have adjusted the code to address a section with insufficient tables.


Sub CreateTestAdv()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngLastBank As Long
Dim bEnough As Boolean
'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) > 0.3 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
lngLastBank = lngQuestions - (lngPerBank * (oDocBank.Sections.Count - 1))
bEnough = True
For lngSect = 1 To oDocBank.Sections.Count - 1
If oDocBank.Sections(lngSec).Range.Tables.Count < lngPerBank Then
bEnough = False
Exit For
End If
Next lngSec
If oDocBank.Sections(oDocBank.Sections.Count).Range.Tables.Count > lngLastBank Then
bEnough = False
End If
If bEnough Then
For lngSec = 1 To oDocBank.Sections.Count
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh)
oDic(lngIndex) = Empty
If lngSec < oDocBank.Sections.Count Then
If oDic.Count = lngPerBank * lngSec Then Exit Do
Else
If oDic.Count = lngQuestions Then Exit Do
End If
Loop
Next lngSec
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in one or more sections of the test bank document to create the test define."
End If
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


24825

[mana]

lngIndex = oRanNumGen.next_2(lngLow, lngHigh + 1)

[gmaxey]

mana,

Thanks. I see now that: 'Next_2method: Returns a random number within the specified range. Is not really true
lngIndex = oRanNumGen.next_2(1, 10) would return numbers 1-9 to return 1-10 you need (1, 11). That does seem a bit odd.




There was a also a typo on this line in the above code:
If oDocBank.Sections(oDocBank.Sections.Count).Range.Tables.Count > lngLastBank Then



Sub CreateTestAdv()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngLastBank As Long
Dim bEnough As Boolean
'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) > 0.3 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
lngLastBank = lngQuestions - (lngPerBank * (oDocBank.Sections.Count - 1))
bEnough = True
For lngSec = 1 To oDocBank.Sections.Count - 1
If oDocBank.Sections(lngSec).Range.Tables.Count < lngPerBank Then
bEnough = False
Exit For
End If
Next lngSec
If oDocBank.Sections(oDocBank.Sections.Count).Range.Tables.Count < lngLastBank Then
bEnough = False
End If
If bEnough Then
For lngSec = 1 To oDocBank.Sections.Count
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh + 1)
oDic(lngIndex) = Empty
If lngSec < oDocBank.Sections.Count Then
If oDic.Count = lngPerBank * lngSec Then Exit Do
Else
If oDic.Count = lngQuestions Then Exit Do
End If
Loop
Next lngSec
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in one or more sections of the test bank document to create the test define."
End If
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub

[gmaxey]

Paul,

Yes, this has lots of possibilities and has been an interesting exercise. May I ask what specific reference you added for the scripting.dictionary? I think they are neat, but I just haven't used them that much, so when I do I am usually befuddled for a bit.

For example, I've been hesitant to admit but for awhile I was baffled by mana's:

oDic(lngIndex) = Empty

... I thought there was something magical going on but in truth I suppose he just arbitrarily used Empty instead of say "Pete's Dragoon" because the process in only interested in the numerical dictionary Key and not the associated item content.

[mana]

I changed the first part of post #24



Sub CreateTestAdv2()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oDicRemain As Object, oDicNotRemain As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim lngSecCount As Long, lngRemain As Long, lngLastTable As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngLastBank As Long
Dim bEnough As Boolean

ClearQuestions

'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
Set oDicRemain = CreateObject("scripting.dictionary")
Set oDicNotRemain = CreateObject("scripting.dictionary")

lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))


bEnough = True
lngSecCount = oDocBank.Sections.Count
lngPerBank = lngQuestions \ lngSecCount

For lngSec = 1 To oDocBank.Sections.Count
If oDocBank.Sections(lngSec).Range.Tables.Count < lngPerBank Then
lngPerBank = oDocBank.Sections(lngSec).Range.Tables.Count
End If
Next

If lngPerBank > 0 Then
lngRemain = lngQuestions Mod lngPerBank * lngSecCount
Else
bEnough = False
End If


If lngRemain Then
Do
lngIndex = oRanNumGen.next_2(1, lngSecCount + 1)
If oDocBank.Sections(lngIndex).Range.Tables.Count > lngPerBank Then
oDicRemain(lngIndex) = Empty
If oDicRemain.Count = lngRemain Then Exit Do
Else
oDicNotRemain(lngIndex) = Empty
If oDicRemain.Count + oDicNotRemain.Count = lngSecCount Then
bEnough = False
Exit Do
End If
End If
Loop
End If


If bEnough Then
For lngSec = 1 To lngSecCount
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
lngLastTable = lngLastTable + lngPerBank - oDicRemain.Exists(lngSec)

Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh + 1)
oDic(lngIndex) = Empty
If oDic.Count = lngLastTable Then Exit Do
Loop
Next lngSec


Application.ScreenUpdating = False

Set oBankTbls = oDocBank.Tables

For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next

Application.ScreenUpdating = True

For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in one or more sections of the test bank document to create the test define."
End If

oDocBank.Close wdDoNotSaveChanges


lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDicRemain = Nothing: Set oDicNotRemain = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub

[Kilroy]

Guys this is really coming along. I was just trying to figure out how to exit if the required questions per section wasn't met and Mana posts. Awesome. Lol my efforts didn't look anything like his. Now to add inputbox for student name, Prepared by, Prepared on. I did some testing:



My “Test bank” is 500 questions
My “Test Bank” has 25 sections
Section 1 has 2 questions
Sections 2 – 25 Have 20 questions



Questions requested

Response



50

50 questions on exam sheet



75

Exits



100

50 questions on exam sheet



125

Exits



150

50 questions on exam sheet



175

Exits



200

50 questions on exam sheet



225

Exits



250

50 questions on exam sheet



275

Exits



300

50 questions on exam sheet



325

Exits



350

50 questions on exam sheet



375

Exits



400

50 questions on exam sheet



425

Exits



450

50 questions on exam sheet



475

Exits



500

50 questions on exam sheet

[gmaxey]

Gents,

Yes. Like a dog with a bone, I can't let it go :crying:

mana, I ran your code with my 250 question bank split in 12 sections (20 in sections 1-11 and 10 in section 12). Using your logic, I got the not enough questions alert when I asked for a test of 150 questions. I can see that there is practically unlimited number of possibilities for section count and questions per section so I just tried to write something that would work for that case. What I've done is attempt to resolve a mix of questions from each section until the total requested is met. I'm not that proficient with a dictionary so I used an array.

Kilroy, as defined, wouldn't your test bank have 482 question if section 1 only has 2 questions ?
Can you test with your bank and see what results you get:


Sub CreateTestAdv2()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim lngIndex As Long, lngQuestions As Long
Dim lngSecCount As Long
Dim lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngRandom As Long, lngCheck As Long
Dim lngCumulative As Long
Dim arrPerSection()
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field

ClearQuestions
'Open the test bank document.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
'Get the number of questions.
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
If lngQuestions > oDocBank.Tables.Count Then
MsgBox "There is not enough questions in the test bank to generate the defined test.", vbInformation + vbOKOnly, "TEST SIZE TOO LARGE FOR BANK"
GoTo lbl_Exit
End If
lngSecCount = oDocBank.Sections.Count
'Develop and store the number of questions to take from each section.
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) >= 0.5 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
ReDim arrPerSection(1 To lngSecCount)
For lngIndex = 1 To lngSecCount
If oDocBank.Sections(lngIndex).Range.Tables.Count > lngPerBank Then
arrPerSection(lngIndex) = lngPerBank
Else
arrPerSection(lngIndex) = oDocBank.Sections(lngIndex).Range.Tables.Count
End If
Next
Do
'Check and resolve questions per section until correct total is achieved.
lngCheck = 0
For lngIndex = 1 To UBound(arrPerSection)
lngCheck = lngCheck + arrPerSection(lngIndex)
Next
Select Case True
Case lngCheck > lngQuestions
lngRandom = oRanNumGen.next_2(1, lngSecCount + 1)
If arrPerSection(lngRandom) > 1 Then
arrPerSection(lngRandom) = arrPerSection(lngRandom) - 1
End If
Case lngCheck < lngQuestions
lngRandom = oRanNumGen.next_2(1, lngSecCount + 1)
If oDocBank.Sections(lngRandom).Range.Tables.Count > arrPerSection(lngRandom) Then
arrPerSection(lngRandom) = arrPerSection(lngRandom) + 1
End If
Case Else
Exit Do
End Select
Loop
'Get the random questions from each section.
For lngIndex = 1 To UBound(arrPerSection)
lngCumulative = lngCumulative + arrPerSection(lngIndex)
Set oBankTbls = oDocBank.Sections(lngIndex).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngRandom = oRanNumGen.next_2(lngLow, lngHigh + 1)
oDic(lngRandom) = Empty
If oDic.Count = lngCumulative Then Exit Do
If oDic.Count = lngQuestions Then Exit Do
Loop
Next lngIndex
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
'Replicate the question bank random questions in the active document.
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequential question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


Hmm. Thoughts after posting:
1. Maybe something to ensure that that question per section is never reduced to 0 would be the next thing ;-). Fixed in code above
2. Maybe a dialog to pick the test bank.

[Kilroy]

See below.

[Kilroy]

Greg you're right of course. I started with 500 and then deleted 18 for the test. I like the way it now will just use the available questions if a section has less than what the average is.

Maybe an input box for names when creating more than one exam would be an idea?

[gmaxey]

Kilroy,

Thanks. Limited testing of course and I suppose there could be some combination of section count, questions per section, and questions requested that will cause it to loop or crash. I've already found and corrected one scenario. That is the case where the number of question requested is less than the bank section count. E.g., requesting a test of 1 question or < than 25 in your case. This should address that:


Sub CreateTestAdv2()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim lngIndex As Long, lngQuestions As Long
Dim lngSecCount As Long
Dim lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngRandom As Long, lngCheck As Long
Dim lngCumulative As Long
Dim arrPerSection()
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field

ClearQuestions
'Open the test bank document.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
'Get the number of questions.
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
Select Case True
Case lngQuestions > oDocBank.Tables.Count
MsgBox "There is not enough questions in the test bank to generate the defined test.", vbInformation + vbOKOnly, "TEST SIZE TOO LARGE FOR BANK"
GoTo lbl_Exit
End Select
lngSecCount = oDocBank.Sections.Count
'Develop and store the number of questions to take from each section.
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) >= 0.5 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
ReDim arrPerSection(1 To lngSecCount)
For lngIndex = 1 To lngSecCount
If oDocBank.Sections(lngIndex).Range.Tables.Count > lngPerBank Then
arrPerSection(lngIndex) = lngPerBank
Else
arrPerSection(lngIndex) = oDocBank.Sections(lngIndex).Range.Tables.Count
End If
Next
Do
'Check and resolve questions per section until correct total is achieved.
lngCheck = 0
For lngIndex = 1 To UBound(arrPerSection)
lngCheck = lngCheck + arrPerSection(lngIndex)
Next
Select Case True
Case lngCheck > lngQuestions
lngRandom = oRanNumGen.next_2(1, lngSecCount + 1)
If lngQuestions >= lngSecCount Then
If arrPerSection(lngRandom) > 1 Then
arrPerSection(lngRandom) = arrPerSection(lngRandom) - 1
End If
Else
If arrPerSection(lngRandom) > 0 Then
arrPerSection(lngRandom) = arrPerSection(lngRandom) - 1
End If
End If
Case lngCheck < lngQuestions
lngRandom = oRanNumGen.next_2(1, lngSecCount + 1)
If oDocBank.Sections(lngRandom).Range.Tables.Count > arrPerSection(lngRandom) Then
arrPerSection(lngRandom) = arrPerSection(lngRandom) + 1
End If
Case Else
Exit Do
End Select
Loop
'Get the random questions from each section.
For lngIndex = 1 To UBound(arrPerSection)
lngCumulative = lngCumulative + arrPerSection(lngIndex)
Set oBankTbls = oDocBank.Sections(lngIndex).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
If arrPerSection(lngIndex) = 0 Then Exit Do
lngRandom = oRanNumGen.next_2(lngLow, lngHigh + 1)
oDic(lngRandom) = Empty
If oDic.Count = lngCumulative Then Exit Do
If oDic.Count = lngQuestions Then Exit Do
Loop
Next lngIndex
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
'Replicate the question bank random questions in the active document.
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequential question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub

[mana]

Option Explicit

Sub CreateTestAdv3()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDicSec As Object, oDicQue As Object, oRanNumGen As Object
Dim oDicAll As Object, oDicOrder As Object, oDicExtract As Object
Dim oTable As Table
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim lngSecCount As Long, lngTable As Long, lngSec As Long
Dim oFld As Field
Dim bEnough As Boolean
Dim n As Long, tmp, i As Long, rn As Long, k

ClearQuestions

'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)

'Iniitalize a dictionary and random number generator object.
Set oDicAll = CreateObject("scripting.dictionary")
Set oDicSec = CreateObject("scripting.dictionary")
Set oDicQue = CreateObject("scripting.dictionary")
Set oDicOrder = CreateObject("scripting.dictionary")
Set oDicExtract = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")

lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))


lngSecCount = oDocBank.Sections.Count
Set oBankTbls = oDocBank.Tables

If oBankTbls.Count >= lngQuestions Then bEnough = True


For i = 1 To lngSecCount
For Each oTable In oDocBank.Sections(i).Range.Tables
n = n + 1
oDicAll(n) = Array(n, i)
Next
Next

For i = 1 To oDicAll.Count - 1
rn = oRanNumGen.next_2(i, oDicAll.Count + 1)
tmp = oDicAll(i)
oDicAll(i) = oDicAll(rn)
oDicAll(rn) = tmp
Next

For Each k In oDicAll.keys
lngTable = oDicAll(k)(0)
lngSec = oDicAll(k)(1)
If Not oDicSec.Exists(lngSec) Then
Set oDicSec(lngSec) = CreateObject("system.collections.queue")
End If
oDicSec(lngSec).enqueue lngTable
Next

For Each k In oDicSec.keys
Set oDicQue(k) = oDicSec(k).Clone
Next

Do
rn = oRanNumGen.next_2(1, lngSecCount + 1)
oDicOrder(rn) = Empty
If oDicOrder.Count = lngSecCount Then Exit Do
Loop

Do
For Each k In oDicOrder.keys
If oDicQue(k).Count > 0 Then
oDicExtract(oDicQue(k).dequeue) = Empty
End If
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop

If bEnough Then
For i = 1 To lngSecCount
Do
If oDicSec(i).Count = 0 Then Exit Do
lngIndex = oDicSec(i).dequeue
If Not oDicExtract.Exists(lngIndex) Then Exit Do
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(lngIndex).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Loop
Next

Application.ScreenUpdating = True

For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in one or more sections of the test bank document to create the test define."
End If

lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oDicAll = Nothing: Set oDicOrder = Nothing: Set oRanNumGen = Nothing
Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicExtract = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTable = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub

[mana]

Instead of dictionary, sortedlist is used to generate a random list of tables.



Sub CreateTestAdv3()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDicSec As Object, oDicQue As Object, oRanNumGen As Object
Dim oAllList As Object, oDicOrder As Object, oDicExtract As Object
Dim oTable As Table
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim lngSecCount As Long, lngTable As Long, lngSec As Long
Dim oFld As Field
Dim bEnough As Boolean
Dim n As Long, tmp, i As Long, rn As Long, k

ClearQuestions

'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)

Set oAllList = CreateObject("system.collections.sortedlist")
Set oDicSec = CreateObject("scripting.dictionary")
Set oDicQue = CreateObject("scripting.dictionary")
Set oDicOrder = CreateObject("scripting.dictionary")
Set oDicExtract = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")

lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))

lngSecCount = oDocBank.Sections.Count
Set oBankTbls = oDocBank.Tables

If oBankTbls.Count >= lngQuestions Then bEnough = True


For i = 1 To lngSecCount
For Each oTable In oDocBank.Sections(i).Range.Tables
n = n + 1
Do
rn = oRanNumGen.Next()
If Not oAllList.contains(rn) Then Exit Do
Loop
oAllList(rn) = Array(n, i)
Next
Next

For i = 0 To oAllList.Count - 1
lngTable = oAllList.GetByIndex(i)(0)
lngSec = oAllList.GetByIndex(i)(1)
If Not oDicSec.Exists(lngSec) Then
Set oDicSec(lngSec) = CreateObject("system.collections.queue")
End If
oDicSec(lngSec).enqueue lngTable
Next

For Each k In oDicSec.keys
Set oDicQue(k) = oDicSec(k).Clone
Next

Do
rn = oRanNumGen.next_2(1, lngSecCount + 1)
oDicOrder(rn) = Empty
If oDicOrder.Count = lngSecCount Then Exit Do
Loop

Do
For Each k In oDicOrder.keys
If oDicQue(k).Count > 0 Then
oDicExtract(oDicQue(k).dequeue) = Empty
End If
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop

Application.ScreenUpdating = False

If bEnough Then
For i = 1 To lngSecCount
Do
If oDicSec(i).Count = 0 Then Exit Do
lngIndex = oDicSec(i).dequeue
If Not oDicExtract.Exists(lngIndex) Then Exit Do
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(lngIndex).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Loop
Next

Application.ScreenUpdating = True

For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in the test bank document to create the test define."
End If

lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oAllList = Nothing: Set oDicOrder = Nothing: Set oRanNumGen = Nothing
Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicExtract = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTable = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub



マナ

[gmaxey]

mana,

All very interesting and it seems to work, as the VBA Locals and Watch windows don't some most of the dictionary values it and without any commenting it is a little difficult to deduce what is actually going on. It seems oDicQue is redundant but it doesn't work without and I don't know why.

[mana]

I'm sorry, it's too difficult to explain with my English proficiency.




as the VBA Locals and Watch windows don't some most of the dictionary values it and without any commenting it is a little difficult to deduce what is actually going on.

Please add 3 lines, and try again


For Each k In oDicSec.keys
Set oDicQue(k) = oDicSec(k).Clone
Next

Dim a, b '<-- add
a = oDicSec.items '<-- add
b = oDicQue.items '<-- add



----
5 lists that needs to be generated.

1) oAllList: random list of all tables
2) oDicSec: random lists per document section
3) oDicQue: duplicae of oDicSec
4) oDicOrder: priority list for choice of document section
5)oDicExtract; list of choosen questions

table number can be obtained from oDicSec according oDicOrder and oDicExtract.


マナ

[gmaxey]

mana,

Yes, it seems that a and b are identical. That is why I don't understand the need for oDicQue and why oDicSec can't be used in place of oDicQue later in the process.

[mana]

Yes, it seems that a and b are identical.


>oDicExtract(oDicQue(k).dequeue) = Empty


after above line, a and b are not identical.
you can use Locel window.



Sub test()
Dim oQue As Object
Dim oQue2 As Object

Set oQue = CreateObject("system.collections.queue")
oQue.enqueue 1
oQue.enqueue 2
oQue.enqueue 3

Set oQue2 = oQue.Clone

MsgBox "oQue: " & Join(oQue.toarray, ",") & vbLf & _
"oQue2: " & Join(oQue2.toarray, ",")

oQue2.dequeue
oQue2.dequeue

MsgBox "oQue: " & Join(oQue.toarray, ",") & vbLf & _
"oQue2: " & Join(oQue2.toarray, ",")

End Sub

[gmaxey]

mana,

Ok. I will look at that. Trying to work through the code, it seems that oDicOrder is redundant. If I use:



' Do
' lngRanNum = oRanNumGen.next_2(1, lngSecCount + 1)
' oDicOrder(lngRanNum) = Empty
' Debug.Print oDicOrder.Count
' If oDicOrder.Count = lngSecCount Then Exit Do
' Loop

Do
For Each oKey In oDicSec.Keys 'oDicOrder.Keys
If oDicQue(oKey).Count > 0 Then
oDicExtract(oDicQue(oKey).dequeue) = Empty
End If
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop

It seems I get the same result. What am I missing?

[mana]

Oh, righjt!
oDicSec is alrady random. oDicOrder is useless.

[gmaxey]

mana,

Thanks for confirmation. I also now see why oDicQue is needed.

Interesting process. Thanks for sharing. Would be a lot easier to follow if the VBE in Office would show more about these objects.

[gmaxey]

mana,

I have been tinkering with your last approach. Please excuse my variable changes (it is just my style). I found what I considered a minor shortcoming and have tried to address it. In my sample test bank there are 13 sections with 10 questions in section 1 and 20 each in sections 2-13.

When I created and exam with 130 questions, ALL questions were used from section 1. I thought it would be an enhancement to "weight" the questions taken from search section.

I've done that by adding an additional dictionary oDicReserve. You might be able to do it using one of the existing dictionaries.

Thanks!!


Sub CreateTestAdv4()
Dim oDocBank As Document
Dim oBankTbls As Tables, oTbl As Table
Dim bEnough As Boolean
Dim oAllList As Object, oRanNumGen As Object
Dim oDicSec As Object, oDicQue As Object, oDicReserve As Object, oDicExtract As Object
Dim lngQuestions As Long
Dim lngSec As Long, lngSecCount As Long
Dim lngIndex As Long, lngTable As Long
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field
Dim dblWt As Double, dblSecWt As Double, lngReserve As Long
Dim lngRanNum As Long, varKey

'Call routine to clear any existing questions.
ClearQuestions
'Open the test bank document.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Get user defined number of questions.
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
Set oBankTbls = oDocBank.Tables
If oBankTbls.Count >= lngQuestions Then bEnough = True
dblWt = lngQuestions / oBankTbls.Count
Set oAllList = CreateObject("system.collections.sortedlist")
Set oRanNumGen = CreateObject("system.random")
Set oDicSec = CreateObject("scripting.dictionary")
Set oDicQue = CreateObject("scripting.dictionary")
Set oDicReserve = CreateObject("scripting.dictionary")
Set oDicExtract = CreateObject("scripting.dictionary")
lngSecCount = oDocBank.Sections.Count

If bEnough Then
'Create a randomized list of the entire bank table collection.
For lngSec = 1 To lngSecCount
'Some sections may have fewer questions than others. Determine the number of questions that should be reserved so all question is
'one section aren't used.
dblSecWt = dblWt * oDocBank.Sections(lngSec).Range.Tables.Count
lngReserve = oDocBank.Sections(lngSec).Range.Tables.Count - Int(dblSecWt)
For Each oTbl In oDocBank.Sections(lngSec).Range.Tables
lngTable = lngTable + 1
Do
lngRanNum = oRanNumGen.Next()
If Not oAllList.contains(lngRanNum) Then Exit Do
Loop
oAllList(lngRanNum) = Array(lngTable, lngSec)
oDicReserve(lngSec) = lngReserve
'Note - resulting list is sorted on the random keys.
Next oTbl 'lngIndex
Next lngSec
'Create a queue (or list of table indexes) for each section
For lngIndex = 0 To oAllList.Count - 1
lngTable = oAllList.GetByIndex(lngIndex)(0) 'Returns the table index number
lngSec = oAllList.GetByIndex(lngIndex)(1) 'Returns the document section number
If Not oDicSec.Exists(lngSec) Then
Set oDicSec(lngSec) = CreateObject("system.collections.queue")
End If
'Add section table index to queue.
oDicSec(lngSec).enqueue lngTable
Next
'Create a clone dictionary
For Each varKey In oDicSec.Keys
Set oDicQue(varKey) = oDicSec(varKey).Clone
Next
Do
For Each varKey In oDicSec.Keys
If oDicQue(varKey).Count >= oDicReserve.Item(varKey) And oDicQue(varKey).Count > 0 Then
'Note: oDicQue(varKey).dequeue returns the index number of a test bank table.
oDicExtract(oDicQue(varKey).dequeue) = Empty
End If
'The keys in oDicExtract define a list of random non-repeating table index numbers.
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop
Application.ScreenUpdating = False
For lngSec = 1 To lngSecCount
Do
If oDicSec(lngSec).Count = 0 Then Exit Do
lngIndex = oDicSec(lngSec).dequeue
If Not oDicExtract.Exists(lngIndex) Then Exit Do
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(lngIndex).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Loop
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in the test bank document to create the test define."
End If
lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oAllList = Nothing: Set oRanNumGen = Nothing
Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicReserve = Nothing: Set oDicExtract = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTbl = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub

[mana]

Thanks. It became very easy to understand.
I think it is better to change like below.



lngReserve = oDocBank.Sections(lngSec).Range.Tables.Count - Int(dblSecWt)
oDicReserve(lngSec) = lngReserve '<-----------moved here
For Each oTbl In oDocBank.Sections(lngSec).Range.Tables

[mana]

I've done that by adding an additional dictionary oDicReserve. You might be able to do it using one of the existing dictionaries.

It's possible.
But I think there is no advantage
Probably such code is poor readability.

[mana]

Like this


'Create a clone dictionary
For Each varKey In oDicSec.Keys
Set oDicQue(varKey) = oDicSec(varKey).Clone
dblSecWt = dblWt * oDicSec(varKey).Count
lngReserve = oDicSec(varKey).Count - Int(dblSecWt)
oDicQue(varKey).enqueue lngReserve
Next
Do
For Each varKey In oDicSec.Keys
With oDicQue(varKey)
If .Count > .toarray()(.Count - 1) And .Count > 1 Then
'Note: oDicQue(varKey).dequeue returns the index number of a test bank table.
oDicExtract(.dequeue) = Empty
End If
End With

[gmaxey]

mana,

I like that! I've made a few more tweaks and comments (more to help me understand) what is going on. One thing I noticed with your suggestion above was it erred if I tried to create a test using ALL questions in the bank. With the following, I was able to create a test of 250 questions (using every question in every section), a test of 13 questions (1 question from each sections) and a dozen or so variations in between e.g., 25 gives 1 question from section 1 and 2 from the others.





Sub CreateTestAdv4()
Dim oDocBank As Document
Dim oBankTbls As Tables, oTbl As Table
Dim bEnough As Boolean
Dim oAllList As Object, oRanNumGen As Object
Dim oDicSec As Object, oDicQue As Object, oDicExtract As Object
Dim lngQuestions As Long
Dim lngSec As Long, lngSecCount As Long
Dim lngIndex As Long, lngTable As Long
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field
Dim dblWt As Double, dblSecWt As Double, lngReserve As Long
Dim lngRanNum As Long, varKey

'Call routine to clear any existing questions.
ClearQuestions
'Open the test bank document.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Get user defined number of questions.
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
Set oBankTbls = oDocBank.Tables
If oBankTbls.Count >= lngQuestions Then bEnough = True

Set oAllList = CreateObject("system.collections.sortedlist")
Set oRanNumGen = CreateObject("system.random")
Set oDicSec = CreateObject("scripting.dictionary")
Set oDicQue = CreateObject("scripting.dictionary")
Set oDicExtract = CreateObject("scripting.dictionary")
lngSecCount = oDocBank.Sections.Count
'Calculate the percentage of questions used.
dblWt = lngQuestions / oBankTbls.Count

If bEnough Then
'Create a randomized list of the entire bank table collection.
For lngSec = 1 To lngSecCount
For Each oTbl In oDocBank.Sections(lngSec).Range.Tables
lngTable = lngTable + 1
Do
lngRanNum = oRanNumGen.Next()
If Not oAllList.contains(lngRanNum) Then Exit Do
Loop
oAllList(lngRanNum) = Array(lngTable, lngSec)
'Note - resulting list is sorted on the random keys.
Next oTbl
'Create queue for questions in each section
Set oDicSec(lngSec) = CreateObject("system.collections.queue")
Next lngSec

'Queue the randomly indexed questions in each section.
For lngIndex = 0 To oAllList.Count - 1
lngTable = oAllList.getByIndex(lngIndex)(0) 'Returns the table index number
lngSec = oAllList.getByIndex(lngIndex)(1) 'Returns the document section number
'Add table index to its section queue.
oDicSec(lngSec).enqueue lngTable
Next

'Clone the oDicSec dictionary and define reserve.
For Each varKey In oDicSec.Keys
Set oDicQue(varKey) = oDicSec(varKey).Clone
'Some sections may have fewer questions than others.
'Calculate the percentage of questions to use from section.
dblSecWt = dblWt * oDicSec(varKey).Count
'Define the number of question to reserve (not use) from the section. This avoids using all questions from a section with fewer questions.
lngReserve = oDicSec(varKey).Count - Int(dblSecWt)
'Save lngReserve as last item in queue
oDicQue(varKey).enqueue lngReserve
Next

'Extract user defined number of questions from the cueued section questions.
Do
For Each varKey In oDicSec.Keys
With oDicQue(varKey)
'Ensure there at least one table index remaining in queue and number in queue is => than calculated reserve
Select Case True
Case lngQuestions < oAllList.Count And lngQuestions > lngSecCount
If .Count > 1 And .Count > .toArray()(.Count - 1) + 1 Then
'Notes:
'If Count = 1 the only data left in queue is the stored reserve
'.toArray()(.Count - 1) returns the stored reserve.
'oDicQue(varKey).dequeue returns the index number of a test bank table.
oDicExtract(.dequeue) = Empty
End If
Case Else
'Case where all questions are used or question count =< section count.
If .Count > 1 And .Count > .toArray()(.Count - 1) Then
oDicExtract(.dequeue) = Empty
End If
End Select
End With
'The keys in oDicExtract define a list of random non-repeating table index numbers.
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop
'Build the test from extracted questions.
Application.ScreenUpdating = False
For lngSec = 1 To lngSecCount
Do
If oDicSec(lngSec).Count = 0 Then Exit Do
'Start dequeing random index numbers from the section queue.
lngIndex = oDicSec(lngSec).dequeue
'Only process table index numbers defined in the extracted queue.
If Not oDicExtract.Exists(lngIndex) Then Exit Do
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(lngIndex).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Loop
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in the test bank document to create the test define."
End If
lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oAllList = Nothing: Set oRanNumGen = Nothing
Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicExtract = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTbl = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub

[mana]

　> Case lngQuestions < oAllList.Count And lngQuestions > lngSecCount
　> Case Else
　> 'Case where all questions are used or question count =< section count.


When lngReserve was calculated by the following formula in all cases,
are there any problems?

lngReserve = Int(oDicSec(varKey).Count - dblSecWt)

[gmaxey]

mana,

That helped.


Sub CreateTestAdv5()
Dim oDocBank As Document
Dim oBankTbls As Tables, oTbl As Table
Dim bEnough As Boolean
Dim oAllList As Object, oRanNumGen As Object
Dim oDicSec As Object, oDicQue As Object, oDicExtract As Object
Dim lngQuestions As Long
Dim lngSec As Long, lngSecCount As Long
Dim lngIndex As Long, lngTable As Long
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field
Dim dblWt As Double, dblSecWt As Double, lngReserve As Long
Dim lngRanNum As Long, varKey

'Call routine to clear any existing questions.
ClearQuestions
'Open the test bank document.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Get user defined number of questions.
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
Set oBankTbls = oDocBank.Tables
If oBankTbls.Count >= lngQuestions Then bEnough = True

Set oAllList = CreateObject("system.collections.sortedlist")
Set oRanNumGen = CreateObject("system.random")
Set oDicSec = CreateObject("scripting.dictionary")
Set oDicQue = CreateObject("scripting.dictionary")
Set oDicExtract = CreateObject("scripting.dictionary")
lngSecCount = oDocBank.Sections.Count
'Calculate the percentage of questions used.
dblWt = lngQuestions / oBankTbls.Count

If bEnough Then
'Create a randomized list of the entire bank table collection.
For lngSec = 1 To lngSecCount
For Each oTbl In oDocBank.Sections(lngSec).Range.Tables
lngTable = lngTable + 1
Do
lngRanNum = oRanNumGen.Next()
If Not oAllList.contains(lngRanNum) Then Exit Do
Loop
oAllList(lngRanNum) = Array(lngTable, lngSec)
'Note - resulting list is sorted on the random keys.
Next oTbl
'Create queue for questions in each section
Set oDicSec(lngSec) = CreateObject("system.collections.queue")
Next lngSec

'Queue the randomly indexed questions in each section.
For lngIndex = 0 To oAllList.Count - 1
lngTable = oAllList.getByIndex(lngIndex)(0) 'Returns the table index number
lngSec = oAllList.getByIndex(lngIndex)(1) 'Returns the document section number
'Add table index to its section queue.
oDicSec(lngSec).enqueue lngTable
Next

'Clone the oDicSec dictionary and define reserve.
For Each varKey In oDicSec.Keys
Set oDicQue(varKey) = oDicSec(varKey).Clone
'Some sections may have fewer questions than others.
'Calculate the percentage of questions to use from section.
dblSecWt = dblWt * oDicSec(varKey).Count
'Define the number of question to reserve (not use) from the section. This avoids using all questions from a section with fewer questions.
lngReserve = Int(oDicSec(varKey).Count - dblSecWt)
'Save lngReserve as last item in queue
oDicQue(varKey).enqueue lngReserve
Next

'Extract user defined number of questions from the cueued section questions.
Do
For Each varKey In oDicSec.Keys
With oDicQue(varKey)
'Ensure there at least one item remaining in queue (the stored reserve) and number of table index numbers in queue is > than calculated reserve
If .Count > 1 And .Count > .toArray()(.Count - 1) + 1 Then
'Notes:
'If Count = 1 the only data left in queue is the stored reserve
'.toArray()(.Count - 1) returns the stored reserve.
'oDicQue(varKey).dequeue returns the index number of a test bank table.
oDicExtract(.dequeue) = Empty
End If
End With
'The keys in oDicExtract define a list of random non-repeating table index numbers.
If oDicExtract.Count = lngQuestions Then Exit Do
Next
Loop
'Build the test from extracted questions.
Application.ScreenUpdating = False
For lngSec = 1 To lngSecCount
Do
If oDicSec(lngSec).Count = 0 Then Exit Do
'Start dequeing random index numbers from the section queue.
lngIndex = oDicSec(lngSec).dequeue
'Only process table index numbers defined in the extracted queue.
If Not oDicExtract.Exists(lngIndex) Then Exit Do
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(lngIndex).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Loop
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in the test bank document to create the test define."
End If
lbl_Exit:
oDocBank.Close wdDoNotSaveChanges
Set oAllList = Nothing: Set oRanNumGen = Nothing
Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicExtract = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTbl = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub
Sub ClearQuestions()
Dim lngIndex As Long
Dim oRng As Range
For lngIndex = ActiveDocument.Tables.Count To 1 Step -1
Set oRng = ActiveDocument.Tables(lngIndex).Range.Paragraphs(1).Range
ActiveDocument.Tables(lngIndex).Delete
oRng.Delete
Next
End Sub

[Artik]

I would like to explain the Next_2 method.
Because my English is perfect like Google Translator :) please refer to the following page: https://kaimi.io/en/2012/04/wsh/
You can find some explanation from the sentence: "What else do you have to know when using .NET assemblies?"


Greg asked for explanation "dic (n) = Empty". This is a simpler record of the structure shown in the code:
Sub BBB()

Dim dic As Object
Dim rn As Object
Dim n
Dim varKeys
Dim varItems


Set rn = CreateObject("system.random")
Set dic = CreateObject("scripting.dictionary")


Do
n = rn.next_2(1, 11)
'dic(n) = Empty
If Not dic.exists(n) Then
dic.Add n, Empty
End If

If dic.Count = 10 Then Exit Do
Loop


varKeys = dic.keys
varItems = dic.items


Stop
End Sub
Artik

[gmaxey]

Artik,

Thanks. My puzzlement was more like what was the purpose of "Empty" The conclusion I came to was mana used Empty not for some real intended purpose but that it really didn't matter what he used. I can replace Empty (which okay might preserve some resources) with:


If Not dic.Exists(n) Then
dic.Add n, "Bob' your uncle"
End If


... and the process works just as well.

Best Regards,
Greg Maxey

Keep away from people who try to belittle your ambitions. Small people always do that, but the really great make you feel that you, too, can become great.
~ Mark Twain

[Kilroy]

This has been an interesting thread!

[sajitsir]

Where is the test generator file or template for this?? I can't find!!!

[sajitsir]

Where is the test generator file for this Test Bank 250.docm??


Kilroy,

Hmm. I created a test bank document (attached) with 250 questions (twenty in sections 1-11 and ten in section 12). Ran the code posted previous and tested with 60, 63, 70 and 73 and all ran fine.

However, I have adjusted the code to address a section with insufficient tables.


Sub CreateTestAdv()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oDic As Object, oRanNumGen As Object
Dim oRng As Range, oRngInsert As Range
Dim lngIndex As Long, lngQuestions As Long
Dim oFld As Field
Dim lngSec As Long, lngLow As Long, lngHigh As Long
Dim lngPerBank As Long, lngLastBank As Long
Dim bEnough As Boolean
'Open the test bank document. The test bank document consists of five sections with 100 questions defined in 100 tables per section.
Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
'Iniitalize a dictionary and random number generator object.
Set oDic = CreateObject("scripting.dictionary")
Set oRanNumGen = CreateObject("system.random")
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
If lngQuestions / oDocBank.Sections.Count - Int(lngQuestions / oDocBank.Sections.Count) > 0.3 Then
lngPerBank = (lngQuestions \ oDocBank.Sections.Count) + 1
Else
lngPerBank = lngQuestions \ oDocBank.Sections.Count
End If
lngLastBank = lngQuestions - (lngPerBank * (oDocBank.Sections.Count - 1))
bEnough = True
For lngSect = 1 To oDocBank.Sections.Count - 1
If oDocBank.Sections(lngSec).Range.Tables.Count < lngPerBank Then
bEnough = False
Exit For
End If
Next lngSec
If oDocBank.Sections(oDocBank.Sections.Count).Range.Tables.Count > lngLastBank Then
bEnough = False
End If
If bEnough Then
For lngSec = 1 To oDocBank.Sections.Count
Set oBankTbls = oDocBank.Sections(lngSec).Range.Tables
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(1).Range.Start
lngLow = oRng.Tables.Count
If lngLow > 1 Then lngLow = lngLow + 1
Set oRng = oDocBank.Range
oRng.End = oBankTbls.Item(oBankTbls.Count).Range.End
lngHigh = oRng.Tables.Count
Do
lngIndex = oRanNumGen.next_2(lngLow, lngHigh)
oDic(lngIndex) = Empty
If lngSec < oDocBank.Sections.Count Then
If oDic.Count = lngPerBank * lngSec Then Exit Do
Else
If oDic.Count = lngQuestions Then Exit Do
End If
Loop
Next lngSec
Application.ScreenUpdating = False
Set oBankTbls = oDocBank.Tables
For lngIndex = 1 To oDic.Count
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(oDic.keys()(lngIndex - 1)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert
Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
'Unlink the sequention question bank number field.
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
'Update the sequential question number field.
ActiveDocument.Fields.Update
Else
MsgBox "There are not enough questions in one or more sections of the test bank document to create the test define."
End If
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDic = Nothing: Set oRanNumGen = Nothing
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


24825

[Artik]

In post #22, just below the code is a link to the document.
You can also see it in the quote, under the code, but under the renamed Attachment 24825.

Artik

[sajitsir]

I am finding the files and codes pretty interesting and fun.

Now my query is -

How do I make it prepare 100 questions by default (as soon as we run the macro) without having to input in the input box, or some way of bypassing the inputbox.

30756


Much thanks in advance!!!


Kilroy,

Yes. It was interesting. In fact, I've played around with the concept a little and decided to start with Test Bank.docm file containing 500 (or any number of questions) and and a Test Generator template with code to generate a test with a user defined number of questions drawn randomly from the test bank.

Here is the code (for simplicity, the code required the Test Bank.docm and Test Generator.dotm files to be located in same folder).

Maybe mana will come back showing how to do the same thing with the system.random. I can't find any information for working with it to say return 100 random out of a possible 500.



Option Explicit

Sub CreateTest()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oRng As Range, oRngInsert As Range
Dim lngCount As Long, lngIndex As Long, lngQuestions As Long
Dim varRanNums
Dim oFld As Field

Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
Set oBankTbls = oDocBank.Tables
Application.ScreenUpdating = False
lngCount = oBankTbls.Count
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
varRanNums = fcnRandomNonRepeatingNumberGenerator(1, lngCount, lngQuestions)
Application.ScreenUpdating = False
For lngIndex = 1 To UBound(varRanNums)
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(varRanNums(lngIndex)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert

Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
ActiveDocument.Fields.Update
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


Function fcnRandomNonRepeatingNumberGenerator(LowerNumber As Long, UpperNumber As Long, _
NumRange As Long) As Variant
Dim lngNumbers As Long, lngRandom As Long, lngTemp As Long
ReDim varNumbers(LowerNumber To UpperNumber) As Variant
Dim varRandomNumbers() As Variant

For lngNumbers = LowerNumber To UpperNumber
varNumbers(lngNumbers) = lngNumbers
Next lngNumbers
Randomize
For lngNumbers = 1 To NumRange
lngRandom = Int(Rnd() * (UpperNumber - LowerNumber + 1 - (lngNumbers - 1))) + (LowerNumber + (lngNumbers - 1))
lngTemp = varNumbers(lngRandom)
varNumbers(lngRandom) = varNumbers(LowerNumber + lngNumbers - 1)
varNumbers(LowerNumber + lngNumbers - 1) = lngTemp
Next lngNumbers
ReDim Preserve varNumbers(LowerNumber To LowerNumber + NumRange - 1)
ReDim varRandomNumbers(1 To NumRange)
For lngNumbers = 1 To NumRange
varRandomNumbers(lngNumbers) = varNumbers(LBound(varNumbers) + lngNumbers - 1)
Next lngNumbers
fcnRandomNonRepeatingNumberGenerator = varRandomNumbers
lbl_Exit:
Exit Function
End Function

Sub ClearQuestions()
Dim lngIndex As Long
Dim oRng As Range
For lngIndex = ActiveDocument.Tables.Count To 1 Step -1
Set oRng = ActiveDocument.Tables(lngIndex).Range.Paragraphs(1).Range
ActiveDocument.Tables(lngIndex).Delete
oRng.Delete
Next
End Sub

[Aussiebear]

My guess from reading the code would be in this line


Set oDocBank = Documents.Open(ThisDocument.Path & "\ Test Bank.Docm", , , False, , , , , , , , False)


is the link, so try changing the name Test Bank.Docm to the name of your document.

[sajitsir]

May be I didn't put it in a proper way. How can I just get 100 questions without the appearance of the input box???

30767

This will make the process quick. If I need to change it, say to 50, I will then change in the code itself. Any help???


Kilroy,

Yes. It was interesting. In fact, I've played around with the concept a little and decided to start with Test Bank.docm file containing 500 (or any number of questions) and and a Test Generator template with code to generate a test with a user defined number of questions drawn randomly from the test bank.

Here is the code (for simplicity, the code required the Test Bank.docm and Test Generator.dotm files to be located in same folder).

Maybe mana will come back showing how to do the same thing with the system.random. I can't find any information for working with it to say return 100 random out of a possible 500.



Option Explicit

Sub CreateTest()
Dim oDocBank As Document
Dim oBankTbls As Tables
Dim oRng As Range, oRngInsert As Range
Dim lngCount As Long, lngIndex As Long, lngQuestions As Long
Dim varRanNums
Dim oFld As Field

Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank.docm", , , False, , , , , , , , False)
Set oBankTbls = oDocBank.Tables
Application.ScreenUpdating = False
lngCount = oBankTbls.Count
lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
varRanNums = fcnRandomNonRepeatingNumberGenerator(1, lngCount, lngQuestions)
Application.ScreenUpdating = False
For lngIndex = 1 To UBound(varRanNums)
Set oRngInsert = ActiveDocument.Bookmarks("QuestionAnchor").Range
Set oRng = oBankTbls(varRanNums(lngIndex)).Range
With oRngInsert
.FormattedText = oRng.FormattedText
.Collapse wdCollapseEnd
.InsertBefore vbCr
.Collapse wdCollapseEnd
End With
ActiveDocument.Bookmarks.Add "QuestionAnchor", oRngInsert

Next
Application.ScreenUpdating = True
For Each oFld In ActiveDocument.Fields
If InStr(oFld.Code, "Bank") > 0 Then oFld.Unlink
Next oFld
ActiveDocument.Fields.Update
oDocBank.Close wdDoNotSaveChanges
lbl_Exit:
Set oDocBank = Nothing: Set oBankTbls = Nothing
Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
Exit Sub
End Sub


Function fcnRandomNonRepeatingNumberGenerator(LowerNumber As Long, UpperNumber As Long, _
NumRange As Long) As Variant
Dim lngNumbers As Long, lngRandom As Long, lngTemp As Long
ReDim varNumbers(LowerNumber To UpperNumber) As Variant
Dim varRandomNumbers() As Variant

For lngNumbers = LowerNumber To UpperNumber
varNumbers(lngNumbers) = lngNumbers
Next lngNumbers
Randomize
For lngNumbers = 1 To NumRange
lngRandom = Int(Rnd() * (UpperNumber - LowerNumber + 1 - (lngNumbers - 1))) + (LowerNumber + (lngNumbers - 1))
lngTemp = varNumbers(lngRandom)
varNumbers(lngRandom) = varNumbers(LowerNumber + lngNumbers - 1)
varNumbers(LowerNumber + lngNumbers - 1) = lngTemp
Next lngNumbers
ReDim Preserve varNumbers(LowerNumber To LowerNumber + NumRange - 1)
ReDim varRandomNumbers(1 To NumRange)
For lngNumbers = 1 To NumRange
varRandomNumbers(lngNumbers) = varNumbers(LBound(varNumbers) + lngNumbers - 1)
Next lngNumbers
fcnRandomNonRepeatingNumberGenerator = varRandomNumbers
lbl_Exit:
Exit Function
End Function

Sub ClearQuestions()
Dim lngIndex As Long
Dim oRng As Range
For lngIndex = ActiveDocument.Tables.Count To 1 Step -1
Set oRng = ActiveDocument.Tables(lngIndex).Range.Paragraphs(1).Range
ActiveDocument.Tables(lngIndex).Delete
oRng.Delete
Next
End Sub