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