excel - 随机化一组值而不重复值索引

Question

我需要随机化或打乱 A 列中的一组单元格，但必须遵守任何单元格均保持不变的约束。

我使用以下代码将候选随机化放在 C 列中:

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

随机化有效，但有时我会得到类似的信息:

当我看到数据项尚未移动时，我重新运行代码，直到所有项目都已移动。

在我看来，这种“如果一开始你没有成功......”的方法真的很愚蠢。

是否有更好的方法来随机化并确保所有项目都已一次性移动？？？

编辑#1:

根据 iliketocode 的评论，我尝试采用 Tony 的方法 this post至 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

我想这个想法是:
用 C2 和 C24 之间的随机选择交换 C1，然后
将 C2 与 C3 和 C24 之间的随机选择交换，然后
将 C3 与 C4 和 C24 之间的随机选择交换，然后
......
在 C23 和 C24 之间随机选择交换 C22，最后
交换 C23 和 C24。

我运行了 1000 次，没有出现不需要的匹配项。

Answer 1

我必须编写自己的工作表版本 RANK function为了与随机值的顺序放置进行比较，但我认为这可能越来越接近。

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

我使用 CF 规则针对原始值反复运行它，该规则突出显示重复项，但从未找到。