Randomize a set of values without repeating value index

Question

I have a requirement to randomize or shuffle a cet of cells in column A subject to the constraint that no cell remains unchanged.

I am placing the candidate randomization in column C with this code:

Sub ShuffleCutandDeal()
    Dim A As Range, C As Range
    Dim B As Range, cell As Range

    Set A = Range("A1:A24")
    Set B = Range("B1:B24")
    Set C = Range("C1")

    A.Copy C

    Randomize
    For Each cell In B
        cell.Value = Rnd()
    Next cell

    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B1:B24") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B1:C24")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

The randomization works, but sometimes I get something like:

When I see that a data item has not moved, I re-run the code until all items have been moved.

It seems to me that this "If at first you don't succeed........." approach is really dumb.

Is there a better way to randomize and insure that all the items have moved in one pass ???

EDIT#1:

Based on iliketocode's comment, I attempted to adapt Tony's approach in this post to VBA:

Sub Tony()
    Dim A As Range, C As Range
    Dim m As Long, t As Variant, i As Long
    Dim wf As WorksheetFunction

    Set wf = Application.WorksheetFunction
    Set A = Range("A1:A24")
    Set C = Range("C1:C24")

    A.Copy C

    For m = 1 To 22
        i = wf.RandBetween(m + 1, 24)
        t = C(i)
        C(i) = C(m)
        C(m) = t
    Next m

    t = C(23)
    C(23) = C(24)
    C(24) = t
End Sub

I guess the idea is to:
Swap C1 with a random pick between C2 and C24 then
Swap C2 with a random pick between C3 and C24 then
Swap C3 with a random pick between C4 and C24 then
................
Swap C22 with a random pick between C23 and C24 and finally
Swap C23 and C24.

I ran this 1000 times with no unwanted matches appearing.

Answer 1

A permutation which moves everything is called a derangement. A classic result in probability is that the probability of a randomly chosen permutation being a derangement is approximately 1/e (where e = 2.71828... is the natural base). This is roughly 37%. Thus -- generating random permutations until you get a derangement is almost certain to work fairly rapidly. Doing anything otherwise risks introducing subtle biases in the distribution of the derangments generated. Of course, you should have the code itself loop until it succeeds rather than rerunning it yourself.

Answer 2

I had to write my own version of the worksheet's native RANK function in order to compare to the ordinal placement of the randomized value but I think this may be getting close.

Option Explicit

Sub shuffleCutDeal()
    Dim i As Long, j As Long, tmp As Variant, vVALs As Variant

    With Worksheets("Sheet1")
        .Columns("B:D").ClearContents
        'get the values from the worksheet
        vVALs = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value2

        'add an extra 'column' for random index position ('helper' rank)
        ReDim Preserve vVALs(LBound(vVALs, 1) To UBound(vVALs, 1), _
                             LBound(vVALs, 2) To UBound(vVALs, 2) + 1)

        'populate the random index positions
        Randomize
        For i = LBound(vVALs, 1) To UBound(vVALs, 1)
            vVALs(i, 2) = Rnd
        Next i

        'check for duplicate index postions and re-randomize
        Do
            Randomize
            For i = LBound(vVALs, 1) To UBound(vVALs, 1)
                If arrRank(vVALs(i, 2), Application.Index(vVALs, 0, 2)) = i Then
                    vVALs(i, 2) = Rnd
                    Exit For
                End If
            Next i
        Loop Until i > UBound(vVALs, 1)

        'sort the variant array
        For i = LBound(vVALs, 1) + 1 To UBound(vVALs, 1)
            For j = LBound(vVALs, 1) To UBound(vVALs, 1) - 1
                If vVALs(i, 2) > vVALs(j, 2) Then
                    tmp = Array(vVALs(i, 1), vVALs(i, 2))
                    vVALs(i, 1) = vVALs(j, 1)
                    vVALs(i, 2) = vVALs(j, 2)
                    vVALs(j, 1) = tmp(0)
                    vVALs(j, 2) = tmp(1)
                End If
            Next j
        Next i

        '[optional] get rid of the 'helper' rank
        'ReDim Preserve vVALs(LBound(vVALs, 1) To UBound(vVALs, 1), _
                              LBound(vVALs, 2) To UBound(vVALs, 2) - 1)

        'return the values to the worksheet
        .Cells(1, 3).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs

    End With

End Sub

Function arrRank(val As Variant, vals As Variant, _
                 Optional ordr As Long = xlDescending)
    Dim e As Long, n As Long

    If ordr = xlAscending Then
        For e = LBound(vals, 1) To UBound(vals, 1)
            n = n - CBool(vals(e, 1) <= val)
        Next e
    Else
        For e = LBound(vals, 1) To UBound(vals, 1)
            n = n - CBool(vals(e, 1) >= val)
        Next e
    End If

    arrRank = n
End Function

I ran it repeatedly against the original values with a CF rule that highlighted duplicates and never found one.