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.
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.
Test Bank 250.docmSub 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
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
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
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.
Last edited by gmaxey; 08-16-2019 at 10:35 AM. Reason: After thoughts and adjust code.
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:
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
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
Last edited by mana; 08-17-2019 at 02:29 AM.
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
マナ
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
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.
マナ
Last edited by mana; 08-17-2019 at 09:37 PM.
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.
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?' 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.