Shuffle an array so no item remains in the same position

Question

I am trying to randomly shuffle an array of strings in VBA, whilst ensuring that no item remains in the same place.

So far I've been adding all items to a collection, then to map the old array onto the shuffled array, I loop through items. Each item removes itself from the collection (so an item never transforms into itself). It then picks a random item from the remaining values, removes that from the collection, and adds itself back to the collection (so a latter item can pick it).

However this occasionally means the last item never gets picked, as the last item cannot pick itself, and all the other items can pick something amongst themselves

Indices is populated with all the people, targets and people are both 1 indexed arrays, where the latter is the array to be shuffled.

For i = 1 To UBound(people) ' loop through people
    stillHere = HasKey(indices, "person" & i) 'only remove self from list if not already taken
    If stillHere Then indecies.Remove "person" & i
    randNum = Application.WorksheetFunction.RandBetween(1, indices.Count)
    targets(i) = people(indices(randNum))
    If indices.Count > 1 Then indices.Remove (randNum) 'don't remove the last item of the collection
    If stillHere Then indices.Add i, "person" & i 'only add self back if not already taken
Next i

user_2474656 · Answer

A shuffling of the items is a permutation of those items. A permutation in which no item remains in its original location is a deranged permutation. See:

Wikipedia Article

Here is a very simple algorithm. The demo code uses for 5 items:

dog
cat
mouse
bird
fish

For each position in the output array, we build a list of candidates from which a random selection is made. So the candidates for the first output exclude "dog". The candidates for the second output exclude "cat" and whatever was picked for the first output.

The candidate list shrinks for each output. The candidate list for the last output only contains a single item, so we pick it.

It is possible that the last output will be the same as the last input. If this undesirable event occurs, we just swap the first and last outputs.

Sub MAIN()
    Dim inpt(1 To 5) As String, Candidate(), j As Long
    Dim i As Long, outpt(), Temp, UTemp As Long
    Dim U As Long, x

    inpt(1) = "dog"
    inpt(2) = "cat"
    inpt(3) = "mouse"
    inpt(4) = "bird"
    inpt(5) = "fish"
    U = UBound(inpt)

    ReDim outpt(1 To U)
    ReDim Candidate(1 To U)
    For i = 1 To U
        Candidate(i) = inpt(i)
    Next i

    For i = 1 To U
        If UBound(Candidate) = 1 Then
            outpt(i) = Candidate(1)
        Else
            outpt(i) = PickValue(Exclude(Candidate, inpt(i)))
            Temp = Exclude(Candidate, outpt(i))
            UTemp = UBound(Temp)
            ReDim Candidate(1 To UTemp)
            For j = 1 To UTemp
                Candidate(j) = Temp(j)
            Next j
        End If

        If inpt(U) = outpt(U) Then
            x = outpt(U)
            outpt(U) = outpt(1)
            outpt(1) = x
        End If



        Cells(i, 2) = inpt(i)
        Cells(i, 4) = outpt(i)

    Next i


End Sub

The Exclude() function inputs an array and a value to be excluded, and outputs a reduced array from which the exclusion was made:

Public Function Exclude(ary As Variant, xClude As Variant) As Variant
    Dim c As Collection, i As Long, cCount As Long
    Set c = New Collection

    For i = LBound(ary) To UBound(ary)
        If ary(i) = xClude Then
        Else
            c.Add ary(i)
        End If
    Next i

    cCount = c.Count
    ReDim bry(1 To c.Count)
    For i = 1 To cCount
        bry(i) = c.Item(i)
    Next i

    Exclude = bry
    Set c = Nothing
End Function

The PickValue() function inputs an array and outputs a random item from that array:

Public Function PickValue(ary) As Variant
    Dim L As Long, U As Long

    L = LBound(ary)
    U = UBound(ary)

        With Application.WorksheetFunction
            PickValue = ary(.RandBetween(L, U))
        End With
End Function

Sample output:

An alternative approach is to:

Create a list of ALL permutations
Remove non-deranged permutations from that list to form a candidate list
Pick a candidate at random.

Admin · Answer

This is a function of Chip Pearson>

http://www.cpearson.com/excel/ShuffleArray.aspx

Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N As Long
    Dim Temp As Variant
    Dim J As Long
    Dim Arr() As Variant


    Randomize
    L = UBound(InArray) - LBound(InArray) + 1
    ReDim Arr(LBound(InArray) To UBound(InArray))
    For N = LBound(InArray) To UBound(InArray)
        Arr(N) = InArray(N)
    Next N
    For N = LBound(InArray) To UBound(InArray)
        J = CLng(((UBound(InArray) - N) * Rnd) + N)
        Temp = Arr(N)
        Arr(N) = ARr(J)
        Arr(J) = Temp
    Next N
    ShuffleArray = Arr
End Function

user_3688861 · Answer

An adapted shuffle array to take into account that no item should be in the same position within the shuffled array. It uses the same initial code as provided by David G. but then tests for collisions and either swaps a single collision with another random member or cycles the subset of collisions around by one if more than one collision is found.

I have used arrays of strings for testing...

Sub TestShuffle()
    Dim Arr() As String
    Arr = Split("1;2;3;4;5", ";")
    Debug.Print Join(ShuffleArray(Arr), ",")
End Sub

Function ShuffleArray(InArray() As String) As String()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    If UBound(InArray) = 1 Then
        ShuffleArray = InArray
        Exit Function
    End If

    Dim N As Long
    Dim Temp As Variant
    Dim J As Long
    Dim Arr() As String
    Dim Collisions As Collection: Set Collisions = New Collection

    Randomize
    L = UBound(InArray) - LBound(InArray) + 1
    ReDim Arr(LBound(InArray) To UBound(InArray))
    For N = LBound(InArray) To UBound(InArray)
        Arr(N) = InArray(N)
    Next N
    For N = LBound(InArray) To UBound(InArray)
        J = CLng(((UBound(InArray) - N) * Rnd) + N)
        Temp = Arr(N)
        Arr(N) = Arr(J)
        Arr(J) = Temp
    Next N

    For N = LBound(InArray) To UBound(InArray)
        If Arr(N) = InArray(N) Then Collisions.Add N
    Next N

    If Collisions.Count > 1 Then
        Temp = Arr(Collisions.Item(1))
        For N = 1 To Collisions.Count - 1
            Arr(Collisions.Item(N)) = Arr(Collisions.Item(N + 1))
        Next N
        Arr(Collisions.Item(N)) = Temp
    ElseIf Collisions.Count = 1 Then
        J = Collisions.Item(1)
        Do Until J <> Collisions.Item(1)
            J = CLng((UBound(InArray) - LBound(InArray)) * Rnd) + LBound(InArray)
        Loop
        Temp = Arr(Collisions.Item(1))
        Arr(Collisions.Item(1)) = Arr(J)
        Arr(J) = Temp
    End If

    ShuffleArray = Arr

End Function

Shuffle an array so no item remains in the same position

3 Answers