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.
Printable View
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.
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.
Attachment 24825Code: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
lngIndex = oRanNumGen.next_2(lngLow, lngHigh + 1)
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
Code: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
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.
I changed the first part of post #24
Code: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
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 questionsQuestions 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
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:
Code: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.
See below.
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?
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:
Code: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
Code: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
Instead of dictionary, sortedlist is used to generate a random list of tables.
Code: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
マナ
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.
I'm sorry, it's too difficult to explain with my English proficiency.
Please add 3 lines, and try again
Code: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.
マナ
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.
>oDicExtract(oDicQue(k).dequeue) = Empty
after above line, a and b are not identical.
you can use Locel window.
Code: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
mana,
Ok. I will look at that. Trying to work through the code, it seems that oDicOrder is redundant. If I use:
It seems I get the same result. What am I missing?Code:' 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
Oh, righjt!
oDicSec is alrady random. oDicOrder is useless.
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.