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