随机化一组值而不重复值索引
我有一个要求，随机或洗牌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的评论，我试图在这个职位上适应托尼的方法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之间的随机select交换C1
然后用C3和C24之间的随机select交换C2
然后用C4和C24之间的随机select交换C3
…………….
用C23和C24之间的随机select交换C22，最后
交换C23和C24。
我跑了这1000次，没有不需要的匹配出现。
我不得不编写我自己的版本的工作表的本地RANK函数 ，以便比较随机值的序号位置，但我认为这可能会越来越接近。
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规则对原始值反复运行，并且从未find一个。
移动一切的排列被称为紊乱 。 一个经典的概率结果是，随机select的置换概率是1 / e（其中e = 2.71828 …是自然基数）。 这大概是37％。 因此 – 产生随机排列，直到发生紊乱，几乎肯定会相当迅速地发挥作用。 否则做任何事情都会在分配所产生的derangements时引入微妙的偏差。 当然，你应该让代码本身循环直到成功，而不是自己重新运行它。