While this seems to work with your sample document (missing question 6), I don't know how it will perform with over 6000 questions. The randomizer is courtesy of Chip Pearson. The tricky part was renumbering the randomized questions:
Option Explicit
Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim arrQ() As String
Dim arrN() As Long
Dim lngIndex As Long
Dim oDocNew As Word.Document
arrQ = Split(ActiveDocument.Range.Text, "Type: ")
arrN = UniqueRandomLongs(1, UBound(arrQ) + 1, UBound(arrQ) + 1)
Set oDocNew = Documents.Add
MsgBox UBound(arrQ)
For lngIndex = 1 To UBound(arrQ) + 1
oDocNew.Range.InsertAfter "Type: " & arrQ(arrN(lngIndex) - 1)
Next lngIndex
CreateSeqs oDocNew
oDocNew.Fields.Update
lbl_Exit:
Exit Sub
End Sub
Sub CreateSeqs(oDoc As Word.Document)
Dim oRng As Word.Range, oRngField
Set oRng = oDoc.Range
With oRng.Find
.Text = "[0-9]@\) "
.MatchWildcards = True
While .Execute
oRng.Select
Set oRngField = oRng.Duplicate
oRngField.End = oRngField.End - 2
oDoc.Fields.Add oRngField, wdFieldSequence, "SeqNum"
oRng.Collapse wdCollapseEnd
Wend
End With
lbl_Exit:
Exit Sub
End Sub
Public Function UniqueRandomLongs(Minimum As Long, Maximum As Long, _
Number As Long, Optional ArrayBase As Long = 1, _
Optional Dummy As Variant) As Variant
'Code courtesy of Chip Pearson: http://www.cpearson.com/excel/RandomNumbers.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' UniqueRandomLongs
' This returns an array containing elements whose values are between the Minimum and
' Maximum parameters. The number of elements in the result array is specified by the
' Number parameter. For example, you can request an array of 20 Longs between 500 and
' 1000 (inclusive).
' There will be no duplicate values in the result array.
'
' The ArrayBase parameter is used to specify the LBound of the ResultArray. If this
' is omitted, ResultArray is 1-based.
'
' The Dummy argument is to be used only when the function is called from a worksheet.
' Its purpose is to allow you to use the NOW() function as the Dummy parameter to force
' Excel to calculate this function any time a calculation is performed. E.g.,
' =UniqueRandomLongs(100,199,10,NOW())
' If you don't want to recalulate this function on every calculation, omit the Dummy
' parameter. The Dummy argument serves no other purpose and is not used anywhere
' in the code.
'
' The function returns an array of Longs if successful or NULL if an error occurred
' (invalid input parameter).
'
' Note: The procedure creates its own array of size (Maximum-Minium+1), so very large
' differences between Minimum and Maximum may cause performace issues.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SourceArr() As Long
Dim ResultArr() As Long
Dim SourceNdx As Long
Dim ResultNdx As Long
Dim TopNdx As Long
Dim Temp As Long
''''''''''''''''''''''''''''''''''''''
' Test the input parameters to ensure
' they are valid.
''''''''''''''''''''''''''''''''''''''
If Minimum > Maximum Then
UniqueRandomLongs = Null
Exit Function
End If
If Number > (Maximum - Minimum + 1) Then
UniqueRandomLongs = Null
Exit Function
End If
If Number <= 0 Then
UniqueRandomLongs = Null
Exit Function
End If
Randomize
''''''''''''''''''''''''''''''''''''''''''''''
' Redim the arrays.
' SourceArr will be sized with an LBound of
' Minimum and a UBound of Maximum, and will
' contain the integers between Minimum and
' Maximum (inclusive). ResultArray gets
' a LBound of ArrayBase and a UBound of
' (ArrayBase+Number-1)
''''''''''''''''''''''''''''''''''''''''''''''
ReDim SourceArr(Minimum To Maximum)
ReDim ResultArr(ArrayBase To (ArrayBase + Number - 1))
''''''''''''''''''''''''''''''''''''''''''''
' Load SourceArr with the integers between
' Minimum and Maximum (inclusive).
''''''''''''''''''''''''''''''''''''''''''''
For SourceNdx = Minimum To Maximum
SourceArr(SourceNdx) = SourceNdx
Next SourceNdx
''''''''''''''''''''''''''''''''''''''''''''''
' TopNdx is the upper limit of the SourceArr
' from which the Longs will be selected. It
' is initialized to UBound(SourceArr), and
' decremented in each iteration of the loop.
' Selections from SourceArr are always in the
' region including and to the left of TopNdx.
' The region above (to the right of) TopNdx
' is where the used numbers are stored and
' no selection is made from that region of
' the array.
''''''''''''''''''''''''''''''''''''''''''''''
TopNdx = UBound(SourceArr)
For ResultNdx = LBound(ResultArr) To UBound(ResultArr)
''''''''''''''''''''''''''''''''''''''''''''''''''
' Set SourceNdx to a random number between 1 and
' TopNdx. ResultArr(ResultNdx) will get its value from
' SourceArr(SourceNdx). Only elements of SourceArr
' in the region of the array below (to the left of)
' TopNdx (inclusive) will be selected for inclusion
' in ResultArr. This ensures that the elements in
' ResultArr are not duplicated.
''''''''''''''''''''''''''''''''''''''''''''''''''
SourceNdx = Int((TopNdx - Minimum + 1) * Rnd + Minimum)
ResultArr(ResultNdx) = SourceArr(SourceNdx)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Now, swap elements SourceNdx and TopNdx of SourceArr,
' moving the value in SourceArr(SourceNdx) to the region
' of SourceArr that is above TopNdx. Since only elements
' of SourceArr in the region below TopNdx (inclusive) are
' possible candidates for inclusion in ResultArr, used
' values are placed at TopNdx to ensure no duplicates.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Temp = SourceArr(SourceNdx)
SourceArr(SourceNdx) = SourceArr(TopNdx)
SourceArr(TopNdx) = Temp
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Decrment TopNdx. This moves the effective UBound of SourceArr
' downwards (to the left), thus removing used numbers from the
' possibility of inclusion in ResultArr. This ensures we have
' no duplicates in the ResultArr.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
TopNdx = TopNdx - 1
Next ResultNdx
''''''''''''''''''''''''''''''
' Return the result array.
''''''''''''''''''''''''''''''
UniqueRandomLongs = ResultArr
End Function
Reply With Quote
