mana,

I have been tinkering with your last approach. Please excuse my variable changes (it is just my style). I found what I considered a minor shortcoming and have tried to address it. In my sample test bank there are 13 sections with 10 questions in section 1 and 20 each in sections 2-13.

When I created and exam with 130 questions, ALL questions were used from section 1. I thought it would be an enhancement to "weight" the questions taken from search section.

I've done that by adding an additional dictionary oDicReserve. You might be able to do it using one of the existing dictionaries.

Thanks!!

Sub CreateTestAdv4()
Dim oDocBank As Document
Dim oBankTbls As Tables, oTbl As Table
Dim bEnough As Boolean
Dim oAllList As Object, oRanNumGen As Object
Dim oDicSec As Object, oDicQue As Object, oDicReserve As Object, oDicExtract As Object
Dim lngQuestions As Long
Dim lngSec As Long, lngSecCount As Long
Dim lngIndex As Long, lngTable As Long
Dim oRng As Range, oRngInsert As Range
Dim oFld As Field
Dim dblWt As Double, dblSecWt As Double, lngReserve As Long
Dim lngRanNum As Long, varKey

  'Call routine to clear any existing questions.
  ClearQuestions
  'Open the test bank document.
  Set oDocBank = Documents.Open(ThisDocument.Path & "\Test Bank 250.docm", , , False, , , , , , , , False)
  'Get user defined number of questions.
  lngQuestions = CLng(InputBox("Enter the number of test questions", "NUMBER OF QUESTIONS", "100"))
  Set oBankTbls = oDocBank.Tables
  If oBankTbls.Count >= lngQuestions Then bEnough = True
  dblWt = lngQuestions / oBankTbls.Count
  Set oAllList = CreateObject("system.collections.sortedlist")
  Set oRanNumGen = CreateObject("system.random")
  Set oDicSec = CreateObject("scripting.dictionary")
  Set oDicQue = CreateObject("scripting.dictionary")
  Set oDicReserve = CreateObject("scripting.dictionary")
  Set oDicExtract = CreateObject("scripting.dictionary")
  lngSecCount = oDocBank.Sections.Count

  If bEnough Then
    'Create a randomized list of the entire bank table collection.
    For lngSec = 1 To lngSecCount
      'Some sections may have fewer questions than others. Determine the number of questions that should be reserved so all question is
      'one section aren't used.
      dblSecWt = dblWt * oDocBank.Sections(lngSec).Range.Tables.Count
      lngReserve = oDocBank.Sections(lngSec).Range.Tables.Count - Int(dblSecWt)
      For Each oTbl In oDocBank.Sections(lngSec).Range.Tables
        lngTable = lngTable + 1
        Do
          lngRanNum = oRanNumGen.Next()
          If Not oAllList.contains(lngRanNum) Then Exit Do
        Loop
        oAllList(lngRanNum) = Array(lngTable, lngSec)
        oDicReserve(lngSec) = lngReserve
        'Note - resulting list is sorted on the random keys.
      Next oTbl 'lngIndex
    Next lngSec
    'Create a queue (or list of table indexes) for each section
    For lngIndex = 0 To oAllList.Count - 1
      lngTable = oAllList.GetByIndex(lngIndex)(0) 'Returns the table index number
      lngSec = oAllList.GetByIndex(lngIndex)(1) 'Returns the document section number
      If Not oDicSec.Exists(lngSec) Then
        Set oDicSec(lngSec) = CreateObject("system.collections.queue")
      End If
      'Add section table index to queue.
      oDicSec(lngSec).enqueue lngTable
    Next
    'Create a clone dictionary
    For Each varKey In oDicSec.Keys
      Set oDicQue(varKey) = oDicSec(varKey).Clone
    Next
    Do
      For Each varKey In oDicSec.Keys
        If oDicQue(varKey).Count >= oDicReserve.Item(varKey) And oDicQue(varKey).Count > 0 Then
          'Note: oDicQue(varKey).dequeue returns the index number of a test bank table.
          oDicExtract(oDicQue(varKey).dequeue) = Empty
        End If
        'The keys in oDicExtract define a list of random non-repeating table index numbers.
        If oDicExtract.Count = lngQuestions Then Exit Do
      Next
    Loop
    Application.ScreenUpdating = False
    For lngSec = 1 To lngSecCount
      Do
        If oDicSec(lngSec).Count = 0 Then Exit Do
        lngIndex = oDicSec(lngSec).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 oRanNumGen = Nothing
  Set oDicSec = Nothing: Set oDicQue = Nothing: Set oDicReserve = Nothing: Set oDicExtract = Nothing
  Set oDocBank = Nothing: Set oBankTbls = Nothing: Set oTbl = Nothing
  Set oRng = Nothing: Set oRngInsert = Nothing: Set oFld = Nothing
End Sub