VBA Script to randomly shuffle text of questions, saving output in another file

[mpeterson]

Hi Guys,

I have a text file that contains over 6000 questions. I'm attaching a sample text file that contains 10 questions.
I need to upload the main text file online after converting it into HTML.
Before converting it to HTML, I need to randomly shuffle the questions' text.
As per attached file:
- each question starts with the word "Type:".
- each question consists of a variable number of paragraphs which represent the body of question, right and wrong answer, and alternative answers.
- questions are separated with an empty line.
- the first question is copied herewith as an example for what is said so far.
Type: MC
1) The 'boot' shape of Italy is an example of what geographical feature?
~ pen·in·su·la Spelled Pronunciation[puh-nin-suh-luh, -nins-yuh-luh] –noun 1. an area of land almost completely surrounded by water except for an isthmus connecting it with the mainland.
@ pen·in·su·la Spelled Pronunciation[puh-nin-suh-luh, -nins-yuh-luh] –noun 1. an area of land almost completely surrounded by water except for an isthmus connecting it with the mainland.
*a. Peninsula
b. Ridge
c. Archipelago
d. Plateau
e. Continent


Is there a way to randomly shuffle all 6000+ questions in the main file, (in order to minimize predictability), into a new file before converting it to HTML?
Any assistance with this issue is very much appreciated.
Thanks in advance.

[gmaxey]

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

[mpeterson]

Greg, you really made me speechless! Truly, I don't know what to say. Your code is working like charm. I just tried it on a bigger file of 100 questions and it did perfectly do its job. The 6000+ file is the compilation of several files each of 100 questions. I will run the code on each of them separate then on every compiled five, then see how it will go with the final compiled one. In case of any negative run, the previous stage will be sufficient before converting to HTML.
Thank you very much Greg; you do have a great and unique input to this world. All the best, and always ahead.

[gmaxey]

You're welcome and thanks for you kind words.