I would suggest the following code to generate a list of random numbers. The
function is set up to return the random values in two ways. It will return a
CSV of the random numbers generated (ie: 1,4,5,6) ... plus if you pass a
variant to the function (the last parameter), the variante will take the form
of an array and will be populated with the random values that were selected.
Note that the forth parameter of the function can be used to indicate whether
or not you wish to have unique values in the set ...
Example Usage:
strMyString = RandomSet(3, 1, 100, True, varMyArray)
The above will set strMyString to a CSV with 3 unique values between 1 and
100, plus the variant variable varMyArray will take the form of an array and
have the same 3 unique values in it.
RandomSet 3, 1, 100, True, varMyArray
Same as above, except since the returned string is not used it will be
disgarded.
RandomSet 3, 1, 100, False, varMyArray
3 random values are selected ... they DO NOT have to be unique ...
Here is the code ...
Public Function RandomSet(lngNumberOfUniqueValues As Long, _
lngMinimum As Long, _
lngMaximum As Long, _
Optional blUnique = True, _
Optional varArray As Variant) As String
'Generates a set of UNIQUE random numbers from a pool of numbers. The
'set is returned as a CSV. IF an array variable is passed to varArray,
'the array is populated with the values.
Dim aLngPool() As Long 'Array to hold the pool of numbers
Dim lngRow As Long 'used as a pointer to a "ROW" of the array
Dim lngTemp As Long 'Used as a temp storage of values
Dim strTemp As String 'Used as a string builder variable
Dim x As Long 'used as a counter
'Size the array to hold ALL the possible values, I think of first
'element of the array as the number of ROWS, the second as the number
'of COLUMNS.
'ReDim aLngPool(1 To (lngMaximum - lngMinimum) + 1, 1 To 2)
ReDim aLngPool(lngMinimum To lngMaximum, 1 To 2)
'Initialize the random number generator
Randomize
'Populate the array with the pool of values, paired with a random number
'this is done so the array can be sorted by the random number later on.
For x = LBound(aLngPool, 1) To UBound(aLngPool, 1)
aLngPool(x, 1) = Int(Rnd * 100000)
If blUnique = True Then
aLngPool(x, 2) = x
Else
aLngPool(x, 2) = Int((lngMaximum - lngMinimum + 1) * Rnd +
lngMinimum)
End If
Next x
'Now that the array is populated, sort the array by the random number
'which is in "column" 1 of the array. We can skip this section if
'unique values are not needed.
If blUnique = True Then
x = UBound(aLngPool, 1)
Do Until x = LBound(aLngPool, 1)
For lngRow = LBound(aLngPool, 1) To x - 1
'Compare the random numbers to determine if the "Rows"
should be swaped
If aLngPool(lngRow, 1) > aLngPool(lngRow + 1, 1) Then
'Swap elements of the array
lngTemp = aLngPool(lngRow, 1)
aLngPool(lngRow, 1) = aLngPool(lngRow + 1, 1)
aLngPool(lngRow + 1, 1) = lngTemp
lngTemp = aLngPool(lngRow, 2)
aLngPool(lngRow, 2) = aLngPool(lngRow + 1, 2)
aLngPool(lngRow + 1, 2) = lngTemp
End If
Next lngRow
x = x - 1
Loop
End If
'Now that the pool of numbers is sorted by the random number, return
'the quanity of unique numbers desired by the caller.
For x = LBound(aLngPool, 1) To LBound(aLngPool, 1) +
lngNumberOfUniqueValues - 1
strTemp = strTemp & "," & aLngPool(x, 2)
Next x
'Return the string
RandomSet = Mid(strTemp, 2)
'Populate the array, if an array is passed
If Not IsMissing(varArray) Then
varArray = Split(Mid(strTemp, 2), ",")
If IsArray(varArray) Then
For x = LBound(varArray) To UBound(varArray)
varArray(x) = Val(varArray(x))
Next x
End If
End If
End Function
Regards,
Brent Spaulding
datAdrenaline | Access MVP