JenniferMurphy
Well-known Member
- Joined
- Jul 23, 2011
- Messages
- 2,532
- Office Version
- 365
- Platform
- Windows
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.
(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.
VBA Code:
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