Question

我要求在 A 列中随机化或随机播放一组cet，但要受制于没有单元格保持不变的约束。

我将候选随机化列在 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然后
用C3和C24之间的随机选择交换C2然后用C4和C24之间的随机选择交换C3然后................
在C23和C24之间随机选择交换C22，最后交换C23和C24。

我跑了1000次，没有出现不想要的比赛。

Answer 1

移动所有内容的排列称为derangement。概率的经典结果是随机选择的排列是紊乱的概率大约是1 / e（其中e = 2.71828 ...是自然基数）。这大约是37％。因此 - 产生随机排列直到你得到紊乱几乎肯定会相当快速地工作。做任何其他事情都有可能在所产生的设计分布中引入微妙的偏见。当然，你应该让代码本身循环，直到它成功，而不是自己重新运行。

Answer 2

我必须编写自己的工作表原生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规则反复对原始值进行了重复操作，该规则突出显示重复项，但从未找到重复项。

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

2 个答案: