VBA code to perform a Fisher-Yates-Knuth random shuffle

[JenniferMurphy]

I just finished writing this code to shuffle a list of values in a named range using the Fisher-Yates-Knuth algorithm.

(a) It works, but there may be a better way. I'd appreciate any comments.

(b) It only works if the named range is a row ($B$7:$W$7). Next I want to generalize it to handle a column ($C$10:$C$200) and then a larger array ($C$7:$G:100). I'd appreciate any suggestions for doing that.

Option Explicit
'====================================================================================
'                   Fisher-Yates-Knuth Shuffle

' Randomly reorder a list of values in cells.
' Flow:
'   Read the input range into an array
'   Shuffle the elements of that array
'   Write it out

'   To Do
' Generalize to handle rows and columns
' Allow it to handle any rectangular range (eg, 10 x 7)
'====================================================================================
Sub FYKShuffle()
Const MyName As String = "FYKShuffle"   'Name of routine for messages
Const rnListInp As String = "ListInp"   'Name of range to be shuffled
Const rnListOut As String = "ListOut"   'Name of range to receive the results

Dim List() As Variant   'Array copy of input values, shuffling will occur here
List = Range(rnListInp).Value   'Load the input list
Dim NumRows As Long     'The number of rows in the list
Dim NumCols As Long     'The number of columns in the list
Dim NumItems As Long    'The number of items to be shuffled
Dim i As Long           'Loop index
Dim iRow As Long        'Row range index
Dim iCol As Long        'Column range index
Dim IsRow As Boolean    'TRUE = row array, FALSE = column array
Dim Item1 As Long       'Item #1 to be swapped
Dim Item2 As Long       'Item #2 to be swapped
Dim t1 As Variant       'Scratch variable
Dim t2 As Variant       'Scratch variable
Dim msg As String       'General messages

NumRows = UBound(List, 1)   'Get the number of rows
NumCols = UBound(List, 2)   'Get the number of columns

If NumRows > 1 Then
  IsRow = True
ElseIf NumCols > 1 Then
  IsRow = False
Else
  MsgBox "This is just a single cell, so no shuffling", vbOKOnly, MyName
  Exit Sub
End If

t1 = Range(rnListOut).Rows.Count
t2 = Range(rnListOut).Columns.Count
If t1 <> NumRows Or t2 <> NumCols Then
  msg = "ERROR: Output shape (" & t1 & "," & t2 & ") different from" _
        & " input shape (" & NumRows & "," & NumCols & ")" & vbCrLf & vbCrLf _
        & "Shuffle aborted"
  MsgBox msg, vbOKOnly, MyName
  Exit Sub
End If

If IsRow Then
  msg = NumRows & " rows"
Else
  msg = NumCols & " columns"
End If

If vbNo = MsgBox("Shuffling " & msg, vbYesNo, MyName) Then
  MsgBox "Shuffling aborted", vbOKOnly, MyName: Exit Sub: End If

' Do the shuffle.
'   Item1 is the one being moved from the end of the remaining list
'   Item2 is the one where it is being moved to
' NOTE: Do it for rows and get that working, then see how to generalize
NumItems = Application.WorksheetFunction.Max(NumRows, NumCols)
iRow = 1
iCol = 1
Randomize
For iCol = NumItems To 2 Step -1
  Item1 = List(iRow, iCol)
  t2 = Int(Rnd() * iCol) + 1
  Item2 = List(iRow, t2)

  List(iRow, iCol) = Item2
  List(iRow, t2) = Item1

Next iCol

Range(rnListOut).Value = List

MsgBox "Done", vbOKOnly, MyName

End Sub

 

[JenniferMurphy]

I now have a version that is generalized to handle rows, columns, and arrays of any size.

I'd still appreciate any comments or suggestions.

'====================================================================================
'                   Fisher-Yates-Knuth Shuffle

' Randomly reorder an array of values in a named range of cells.
' The named range can be a row, a column, or an NxM array.

' Flow:
'   Work backwards from the last item in the "working" array to the 2nd.
'   Generate a random index from 1 to the last item in the working array.
'   Swap the last item with the one at the random location.
'   Shorten the working array by 1 & repeat.
'   When fully shuffled, write it to the output named range
'     (This may be the same as the input range)
'====================================================================================
Sub Shuffle()
Const MyName As String = "Shuffle"      'Name of this routine for messages
Const rnArrayInp As String = "ArrayInp" 'Name of range to be shuffled
Const rnArrayOut As String = "ArrayOut" 'Name of range to receive the results

Dim ArrayInp() As Variant 'Memory copy of input values, shuffling will occur here
Dim NumRows As Long       'The number of rows in the Array
Dim NumCols As Long       'The number of columns in the Array
Dim NumItems As Long      'The number of items to be shuffled (rows x cols)
Dim i As Long             'Loop index
Dim iRow1 As Long         'Row array index for 1st swap item
Dim iCol1 As Long         'Column range index for 1st swap item
Dim Item1 As Long         'Item #1 to be swapped
Dim iRow2 As Long         'Row array index for 2nd swap item
Dim iCol2 As Long         'Column range index for 2nd swap item
Dim Item2 As Long         'Item #2 to be swapped
Dim t1 As Variant         'Scratch variable
Dim t2 As Variant         'Scratch variable
Dim msg As String         'General messages

' Check array size first. VBA doesn't consider a 1x1 array an indexable array.
NumRows = Range(rnArrayInp).Rows.Count
NumCols = Range(rnArrayInp).Columns.Count
If NumRows = 1 And NumCols = 1 Then
  MsgBox "This is just a single cell, so no shuffling", vbOKOnly, MyName
  Exit Sub
End If

' Make sure the output range is the same shape as the input
' It can be the exact same range.
t1 = Range(rnArrayOut).Rows.Count
t2 = Range(rnArrayOut).Columns.Count
If t1 <> NumRows Or t2 <> NumCols Then
  msg = "ERROR: Output shape (" & t1 & "," & t2 & ") different from" _
        & " input shape (" & NumRows & "," & NumCols & ")" & vbCrLf & vbCrLf _
        & "Shuffle aborted"
  MsgBox msg, vbOKOnly, MyName
  Exit Sub
End If

ArrayInp = Range(rnArrayInp).Value   'Load the input Array

msg = "Shuffling an array of " & NumRows & " rows and " & NumCols & " columns." _
      & vbCrLf & vbCrLf & "Select 'Yes' to continue or 'No' to abort"
If vbNo = MsgBox(msg, vbYesNo, MyName) Then
  MsgBox "Shuffling aborted", vbOKOnly, MyName: Exit Sub: End If

' Do the shuffle.
'   Item1 is the one being moved from the end of the remaining Array
'   Item2 is the one where it is being moved to (swapped with)
NumItems = NumRows * NumCols
Randomize

For i = NumItems To 2 Step -1
  'Get the row and column number for the next 1st swap item
  iRow1 = Application.WorksheetFunction.RoundUp(i / NumCols, 0)
  iCol1 = ((i - 1) Mod NumCols) + 1
  Item1 = ArrayInp(iRow1, iCol1)
  'Get the row and column number for the next 1st swap item
  t2 = Int(Rnd() * i) + 1
  iRow2 = Application.WorksheetFunction.RoundUp(t2 / NumCols, 0)
  iCol2 = ((t2 - 1) Mod NumCols) + 1
  Item2 = ArrayInp(iRow2, iCol2)
  'Swap the items
  ArrayInp(iRow1, iCol1) = Item2
  ArrayInp(iRow2, iCol2) = Item1
Next i

Range(rnArrayOut).Value = ArrayInp  'Output the shuffled items

MsgBox "Done", vbOKOnly, MyName

End Sub