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