値インデックスを繰り返さずに値のセットをランダム化する

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回のパスで移動したことを確認する良い方法はありますか？

EDIT＃1：iliketocodeさんのコメントに基づいて、私はにthis postでトニーのアプローチを適応させるためにVBAしようとし

：

私はアイデアがある推測する：
スワップC1とC2とC24の間のランダムな選択
C3とC24の間のランダムな選択でC2をスワップすると、
C4とC24の間のランダムな選択でC3をスワップすると、
................
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 

私は重複を強調表示し、1を発見したことはありませんCFルールと元の値に対して繰り返し、それを実行しました。

Answer 2

すべてを動かすパーミュテーションをderangementといいます。確率の古典的な結果は、無作為に選ばれた順列が狂っている確率が約1/e（e = 2.71828 ...が自然な基底である）です。これはおよそ37％です。このように、ランダムな順列を生成することは、混乱を招くようになり、かなり急速に機能します。そうでなければ何かをすると、生成された脱線の分布に微妙な偏りが生じる危険性があります。もちろん、コード自体を再実行するのではなく、成功するまでループする必要があります。