The following type of question comes up on the online forums very frequently:
Using VBA I would like to have an array holding random numbers between 1 and 10 without duplicates.
The words to pick up on are ‘without duplicates’: the numbers are not random, but their order is. The most efficient way to do this is to put the numbers 1 to 10 into an array and shuffle them into a random order. I don’t need to do this very often in my line of work but, for those occasions when I do, I have this Fisher-Yates shuffle routine sitting in my code library ready for action.
Sub Shuffle(ByRef lngarrNumbers() As Long)
Dim lngTemp As Long 'temporary holder for the element being swapped out
Dim lngRandom As Long 'random position within the array
Dim lngCounter As Long 'simple counter
Dim lngUpper As Long 'the upper bound of the array
Dim lngLower As Long 'the lower bound of the array
lngLower = LBound(lngarrNumbers)
lngUpper = UBound(lngarrNumbers)
'initialise VBA's random number generator
Randomize
For lngCounter = lngUpper To (lngLower + 1) Step -1
'generate random number between lngLower and lngCounter inclusive
lngRandom = CLng(Int((lngCounter - lngLower + 1) * Rnd + lngLower))
'temporarily save the element being swapped out
lngTemp = lngarrNumbers(lngCounter)
'randomly swap another element in
lngarrNumbers(lngCounter) = lngarrNumbers(lngRandom)
'put the swapped out number back in where the
'other number came from
lngarrNumbers(lngRandom) = lngTemp
Next lngCounter
End Sub
The array is passed ByRef, so its randomised order is passed directly back to the caller procedure. Here’s an example which shows how to use the Shuffle procedure:
Sub Example()
Const strDELIMITER As String = ","
Dim lngarrNumbers() As Long
Dim lngCounter As Long
ReDim lngarrNumbers(0 To 9)
'populate the array with the numbers
'1 to 10, in numerical sequence
Debug.Print "Before: ";
For lngCounter = LBound(lngarrNumbers) To UBound(lngarrNumbers)
lngarrNumbers(lngCounter) = lngCounter + 1
Debug.Print lngarrNumbers(lngCounter) & _
IIf(lngCounter < UBound(lngarrNumbers), strDELIMITER, vbNewLine);
Next lngCounter
'shuffle the array
Shuffle lngarrNumbers
Debug.Print "After: ";
'let's observe the random order of the numbers
For lngCounter = LBound(lngarrNumbers) To UBound(lngarrNumbers)
Debug.Print lngarrNumbers(lngCounter) & _
IIf(lngCounter < UBound(lngarrNumbers), strDELIMITER, vbNewLine);
Next lngCounter
End Sub
Sub Shuffle(ByRef lngarrNumbers() As Long)
Dim lngTemp As Long 'temporary holder for the element being swapped out
Dim lngRandom As Long 'random position within the array
Dim lngCounter As Long 'simple counter
Dim lngUpper As Long 'the upper bound of the array
Dim lngLower As Long 'the lower bound of the array
lngLower = LBound(lngarrNumbers)
lngUpper = UBound(lngarrNumbers)
'initialise VBA's random number generator
Randomize
For lngCounter = lngUpper To (lngLower + 1) Step -1
'generate random number between lngLower and lngCounter inclusive
lngRandom = CLng(Int((lngCounter - lngLower + 1) * Rnd + lngLower))
'temporarily save the element being swapped out
lngTemp = lngarrNumbers(lngCounter)
'randomly swap another element in
lngarrNumbers(lngCounter) = lngarrNumbers(lngRandom)
'put the swapped out number back in where the
'other number came from
lngarrNumbers(lngRandom) = lngTemp
Next lngCounter
End Sub
How can I make the Shuffle sub into an excel function?
LikeLike
Hi Daniel,
There are a couple of points we need to take into account if we want to create a VBA UDF which shuffles numbers. Firstly, all numbers on Excel worksheets are Double types – not Long types – so we’ll need to update the shuffle sub to accept a 1-D array of doubles. Like so:
Sub Shuffle(ByRef dblarrNumbers() As Double) Dim dblTemp As Double 'temporary holder for the element being swapped out Dim lngRandom As Long 'random position within the array Dim lngCounter As Long 'simple counter Dim lngUpper As Long 'the upper bound of the array Dim lngLower As Long 'the lower bound of the array lngLower = LBound(dblarrNumbers) lngUpper = UBound(dblarrNumbers) 'initialise VBA's random number generator Randomize For lngCounter = lngUpper To (lngLower + 1) Step -1 'generate random number between lngLower and lngCounter inclusive lngRandom = CLng(Int((lngCounter - lngLower + 1) * Rnd + lngLower)) 'temporarily save the element being swapped out dblTemp = dblarrNumbers(lngCounter) 'randomly swap another element in dblarrNumbers(lngCounter) = dblarrNumbers(lngRandom) 'put the swapped out number back in where the 'other number came from dblarrNumbers(lngRandom) = dblTemp Next lngCounter End SubNow we can build up a VBA UDF wrapper function called SHUFFLENUMBERS() which utilises our Shuffle sub. We have to consider the dimensions of the range which will be passed into our UDF:
If a single cell is passed in then we don’t need to shuffle. If a range of multiple cells is passed in then it will be a 2 dimensional array of numbers. This causes a problem because the Shuffle() sub takes a 1 dimensional double array which is passed ByRef. We could amend Shuffle() so that it takes a 2 dimensional array but I’ll try something different: I’ll put the numbers from the range into a 1 dimensional array, shuffle that and then put those shuffled numbers back into a 2 dimensional array to be returned to the worksheet. Here’s my first crack on it:
Public Function SHUFFLENUMBERS(ByRef rngNumbers As Range) As Variant Dim dblarrInput() As Double 'all numbers in worksheets are doubles Dim dblarrOutPut() As Double Dim rngCell As Range Dim lngRows As Long Dim lngCols As Long Dim i As Long Dim j As Long Dim k As Long Dim l As Long 'optional - force it to recalculate on every calculation event Application.Volatile On Error GoTo ErrorHandler 'what size array do we want to return? 'we will base this on the size of rngNumbers 'if you are using XL 2003 or earlier then use .Count 'instead of .CountLarge lngRows = rngNumbers.Rows.CountLarge lngCols = rngNumbers.Columns.CountLarge 'we don't need to shuffle if only a single cell was passed in If lngRows = 1 And lngCols = 1 Then ReDim dblarrOutPut(0 To 0) dblarrOutPut = rngNumbers.Value2 Else 'put the numbers into a 1 dimensional double array 'if the cell is empty then 0 will be passed in 'if the cell contains a value which can't be 'converted to a double then an error will be thrown ReDim dblarrInput(0 To lngRows * lngCols - 1) For Each rngCell In rngNumbers.Cells dblarrInput(i) = rngCell.Value2 i = i + 1 Next rngCell 'put the numbers in a random order Shuffle dblarrInput 'transfer the numbers into our 2 dimensional output array ReDim dblarrOutPut(0 To lngRows - 1, 0 To lngCols - 1) For j = LBound(dblarrOutPut, 1) To UBound(dblarrOutPut, 1) For k = LBound(dblarrOutPut, 2) To UBound(dblarrOutPut, 2) dblarrOutPut(j, k) = dblarrInput(l) l = l + 1 Next k Next j End If SHUFFLENUMBERS = dblarrOutPut Exit Function ErrorHandler: SHUFFLENUMBERS = CVErr(xlErrNum) End FunctionSo, to summarise –
* SHUFFLENUMBERS() is a VBA UDF which is to be used in formulas from the worksheet. It returns an array so select a range of the correct size, type in the formula and press CTRL+SHIFT+ENTER.
* I’ve made SHUFFLENUMBERS() volatile so it recalculates on every calculation event. Remove Application.Volatile to turn this off.
* The Shuffle() sub also needs to be in the project but can only be called from other VBA code and not from the worksheet.
* If an empty cell is passed into the UDF then the empty value will be internally converted to 0.
* If the array range (containing the formula) is larger than rngNumbers then excess cells will hold #N/A values.
* If rngNumbers holds a value which cannot be converted to a number, or if a runtime error occurs, then the formula will return #NUM!.
LikeLike
Thank you very much.
LikeLike