Consulting

Page 2 of 3 FirstFirst 1 2 3 LastLast
Results 21 to 40 of 56

Thread: How to scramble tables in word

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

  2. #22
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Kilroy,

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

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

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

    Visit my website: http://gregmaxey.com

  3. #23
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    lngIndex = oRanNumGen.next_2(lngLow, lngHigh + 1)

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

    Visit my website: http://gregmaxey.com

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

    Visit my website: http://gregmaxey.com

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

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

    My “Test bank” is 500 questions
    My “Test Bank” has 25 sections
    Section 1 has 2 questions
    Sections 2 – 25 Have 20 questions
    Questions requested Response
    50 50 questions on exam sheet
    75 Exits
    100 50 questions on exam sheet
    125 Exits
    150 50 questions on exam sheet
    175 Exits
    200 50 questions on exam sheet
    225 Exits
    250 50 questions on exam sheet
    275 Exits
    300 50 questions on exam sheet
    325 Exits
    350 50 questions on exam sheet
    375 Exits
    400 50 questions on exam sheet
    425 Exits
    450 50 questions on exam sheet
    475 Exits
    500 50 questions on exam sheet

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

    Visit my website: http://gregmaxey.com

  9. #29
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    See below.

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

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

    Visit my website: http://gregmaxey.com

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

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

    マナ

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

    Visit my website: http://gregmaxey.com

  15. #35
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    I'm sorry, it's too difficult to explain with my English proficiency.

    Quote Originally Posted by gmaxey View Post

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

        For Each k In oDicSec.keys
            Set oDicQue(k) = oDicSec(k).Clone
        Next
        
        Dim a, b        '<-- add
        a = oDicSec.items    '<-- add
        b = oDicQue.items    '<-- add

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

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

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


    マナ
    Last edited by mana; 08-17-2019 at 09:37 PM.

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

    Visit my website: http://gregmaxey.com

  17. #37
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    Quote Originally Posted by gmaxey View Post
    Yes, it seems that a and b are identical.

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


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


    Sub test()
        Dim oQue As Object
        Dim oQue2 As Object
        
        Set oQue = CreateObject("system.collections.queue")
        oQue.enqueue 1
        oQue.enqueue 2
        oQue.enqueue 3
        
        Set oQue2 = oQue.Clone
     
        MsgBox "oQue: " & Join(oQue.toarray, ",") & vbLf & _
                "oQue2: " & Join(oQue2.toarray, ",")
                
        oQue2.dequeue
        oQue2.dequeue
        
        MsgBox "oQue: " & Join(oQue.toarray, ",") & vbLf & _
                "oQue2: " & Join(oQue2.toarray, ",")
         
    End Sub

  18. #38
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    mana,

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

    '  Do
    '    lngRanNum = oRanNumGen.next_2(1, lngSecCount + 1)
    '    oDicOrder(lngRanNum) = Empty
    '    Debug.Print oDicOrder.Count
    '    If oDicOrder.Count = lngSecCount Then Exit Do
    '  Loop
        
      Do
        For Each oKey In oDicSec.Keys 'oDicOrder.Keys
          If oDicQue(oKey).Count > 0 Then
            oDicExtract(oDicQue(oKey).dequeue) = Empty
          End If
          If oDicExtract.Count = lngQuestions Then Exit Do
        Next
      Loop
    It seems I get the same result. What am I missing?
    Greg

    Visit my website: http://gregmaxey.com

  19. #39
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    Oh, righjt!
    oDicSec is alrady random. oDicOrder is useless.

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