Visual Basic for Applications/The Knuth String Shuffle

Summary

• This code module includes both a Fisher-Yates character shuffling routine for strings, and a Durstenfeld-Knuth routine to shuffle one-dimensional arrays.
  • The procedure FisherYatesStrShuffle() shuffles characters of a single string. This is limited to shifting single characters around within one string.
  • Procedure KnuthArrShuffle() sorts the elements of a one-dimensional array. The procedure is limited only by what can be stored in array elements.
• The two methods are pseudo-random and bias-free. Elsewhere, the use of a random generator does not necessarily guarantee that the results will be free from bias.
• The code can work in any of the MS Office applications that support VBA.

Code Notes

• The Fisher-Yates shuffle applies a pseudo random selection method. It is described here for characters in a string but a related method, the Durstenfeld-Knuth method is preferred for arrays.
  • Taking each element of a string in sequence for repositioning leaves one end of the result string badly biased. The Knuth algorithm instead proposes a random position within the string. The element at that position is then accumulated into the output and removed from the original. Subsequent selections are made in the same way from the ever shortened string.
  • Note that there is still the possibility of a given character being unmoved in the process, but only within expectation.
  • Set the number of strings required with variable Cycles in the top procedure. The Immediate Window has proved the best place for display and copying.
  • It should be pointed out that any attempt to avoid the unmoved elements, will not only change the random nature of the shuffle but prevent the use of other than non-repeat strings. That is to say strings with repeated characters could not then be shuffled.
• The Durstenfeld-Knuth method for arrays differs only slightly from that of the Fisher-Yates implementation.
  • To reduce processing, and no doubt to overcome the burden of removing an element from the middle of an array during shortening, the algorithm instead overwrites the element selected for output with the last element. In this VBA implementation the array is then conveniently shortened by one element with Redim Preserve.
• See Fisher Yates Shuffle for a good description of both methods.

The VBA Code Module

Copy all of the code below into say, an MS Excel standard module, save the workbook as an xlsm file type, and run either of the test procedures to test the requisite code. Be sure to open the Immediate Window for output.

Option Explicit

Private Sub testFisherYatesStrShuffle()
    'run this to test the string shuffle
    
    Dim bOK As Boolean, sStr As String, sR As String
    Dim sOut As String, n As Long, Cycles As Long
    
    'set number of shuffled versions needed
    Cycles = 1
    
    'test string
    sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

    For n = 1 To Cycles
        bOK = FisherYatesStrShuffle(sStr, sR)
        sOut = sR
        
        If bOK = False Then
           MsgBox "Problems in shuffle"
           Exit Sub
        End If
        
        'output to message box and immediate window
        'MsgBox "Before : " & sStr & vbCrLf & _
               "After    : " & sR
        Debug.Print "Before : " & sStr
        Debug.Print "After  : " & sOut & vbCrLf
    Next n
    
End Sub

Private Function FisherYatesStrShuffle(ByVal sIn As String, sOut As String) As Boolean
    'Performs a naive Fisher-Yates shuffle on the input string.
    'Returns result in sOut. Pseudo random character sequencing.
    
    'Note: Some or all elements could occupy their original positions,
    'but only in accordance with expectation based on the random generator.
    'This can be seen best for very short character strings, like "ABC".
            
    Dim sL As String, sR As String, sT1 As String, sT2 As String, sMod As String
    Dim sAcc As String, i As Long, j As Long, nL As Long, n As Long
        
    'check input string
    If sIn = "" Or Len(sIn) < 2 Then
       MsgBox "At least 2 characters needed - closing"
       Exit Function
    End If
        
    'initial assignments
    nL = Len(sIn)
    sMod = sIn
    
    Randomize
    For i = 1 To Len(sIn)
        'first get a random number
        j = Int((nL - 1 + 1) * Rnd + 1)
            
        'find string value of jth element
        sT1 = Mid$(sMod, j, 1)
        DoEvents 'allow break
                
        'accumulate jth element
        sAcc = sAcc & sT1
        
        'remove current character
        sL = Left$(sMod, j - 1)
        sR = Right$(sMod, nL - j)
        sMod = sL & sR
        
        'new string length
        nL = Len(sMod)
        DoEvents 'allow break
    Next i

    'transfer
    sOut = sAcc
    
    FisherYatesStrShuffle = True

End Function

Private Sub testKnuthArrShuffle()
    'run this to test the array shuffle
    
    Dim bOK As Boolean, sStr As String, sOut As String
    Dim Cycles As Long, n As Long, bF As Boolean
    Dim vS As Variant, vA As Variant, vB As Variant
           
    'define a typical array for shuffling
    vS = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
               "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
               "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    
    'set number of shuffled versions needed
    Cycles = 1
    
    For n = 1 To Cycles
    
        'shuffle array
        bOK = KnuthArrShuffle(vS, vA)
                
        If bOK = False Then
           MsgBox "Problems in array shuffle"
           Exit Sub
        End If
            
        'arrays to strings for display
        sStr = Arr1DToStr2(vS)
        sOut = Arr1DToStr2(vA)
        
        'display
    '    MsgBox "Before : " & sStr & vbCrLf & _
    '           "After    : " & sOut
        Debug.Print "Before : " & sStr
        Debug.Print "After  : " & sOut & vbCrLf
           
        'return to an array in vB if needed
        bF = StrTo1DArr2(sOut, vB)

    Next n

End Sub

Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
    ' Performs a modified Knuth random shuffle on the elements of the input array.
    ' The original by Fisher-Yates, was modified for computers by Durstenfeld
    ' then popularised by Knuth. Returns result in vR with vIn unchanged.
       
    'Note: Some or all elements COULD occupy their original positions,
    'but only in accordance with expectation based on the random generator.
    'This is best seen for small arrays, say with only 3 elements or so.
        
    Dim vW As Variant
    Dim LB As Long, UB As Long, nL As Long
    Dim i As Long, j As Long
    
    'initial assignments
    LB = LBound(vIn): UB = UBound(vIn)
    ReDim vR(LB To UB) 'return array
    ReDim vW(LB To UB) 'work array
    nL = UB - LB + 1   'length of input array
    vW = vIn 'transfer to a work array
            
    'working
    Randomize
    For i = LB To nL
        'first get a random number
        j = Int((UB - LB + 1) * Rnd + LB)
            
        'transfer jth of vW to ith of vR
        vR(i) = vW(j)
        
        'replace selection with current last of vW
        vW(j) = vW(UB)
        
        'remove last of vW by shortening array
        ReDim Preserve vW(LB To UB - 1)
        
        'get new UBound of shortened vW
        UB = UBound(vW)
        
        'exception; return if last chara
        If UB = LB Then
            vR(i + 1) = vW(UB)
            Exit For
        End If
                
        DoEvents 'allow breaks
    Next i
        
    KnuthArrShuffle = True

End Function
Function StrTo1DArr2(ByVal sIn As String, vRet As Variant, _
                    Optional ByVal bLB1 As Boolean = True) As Boolean
    ' Loads string characters into 1D array (vRet). One per element.
    ' Optional choice of lower bound. bLB1 = True for one-based (default),
    ' else bLB1 = False for zero-based. vRet dimensioned in proc.

    Dim nC As Long, sT As String
    Dim LB As Long, UB As Long
    
    If sIn = "" Then
        MsgBox "Empty string - closing"
        Exit Function
    End If
    
    'allocate array for chosen lower bound
    If bLB1 = True Then
        ReDim vRet(1 To Len(sIn))
    Else
        ReDim vRet(0 To Len(sIn) - 1)
    End If
    LB = LBound(vRet): UB = UBound(vRet)

    'load charas of string into array
    For nC = LB To UB
        If bLB1 = True Then
            sT = Mid$(sIn, nC, 1)
        Else
            sT = Mid$(sIn, nC + 1, 1)
        End If
        vRet(nC) = sT
    Next

    StrTo1DArr2 = True

End Function
    
Function Arr1DToStr2(vIn As Variant) As String
    ' Makes a single string from 1D array string elements.
    ' Works for any array bounds.
        
    Dim nC As Long, sT As String, sAccum As String
    Dim LB As Long, UB As Long
    
    LB = LBound(vIn): UB = UBound(vIn)

    'join characters of array into string
    For nC = LB To UB
        sT = vIn(nC)
        sAccum = sAccum & sT
    Next

    Arr1DToStr2 = sAccum

End Function

See Also

• Fisher Yates Shuffle: A very clearly written article in Wikipedia, that explains worked examoles step by step.