Consulting

Page 1 of 3 1 2 3 LastLast
Results 1 to 20 of 56

Thread: How to scramble tables in word

  1. #1
    VBAX Newbie
    Joined
    Aug 2019
    Posts
    2
    Location

    How to scramble tables in word

    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.

  2. #2
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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

  3. #3
    VBAX Newbie
    Joined
    Aug 2019
    Posts
    2
    Location
    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.

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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

    マナ
    Last edited by mana; 08-10-2019 at 02:02 AM.

  6. #6
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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
    マナ
    Last edited by mana; 08-10-2019 at 04:45 AM.

  7. #7
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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?
    Greg

    Visit my website: http://gregmaxey.com

  8. #8
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    > 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

  9. #9
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    > 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.



  10. #10
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  11. #11
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    > oRng2.FormattedText = oRng.FormattedText


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

  12. #12
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    Greg, Mana thanks for your efforts on this one. Very interesting.

  13. #13
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Attached Files Attached Files
    Last edited by gmaxey; 08-13-2019 at 10:42 AM.
    Greg

    Visit my website: http://gregmaxey.com

  14. #14
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  15. #15
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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”?
    Last edited by Kilroy; 08-14-2019 at 09:38 AM. Reason: speling

  16. #16
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  17. #17
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Last edited by Paul_Hossler; 08-15-2019 at 08:46 AM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  18. #18
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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
    Last edited by Kilroy; 08-15-2019 at 10:37 AM. Reason: information

  19. #19
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  20. #20
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •