VBA Collectionを使って数値をランダムに並び替える

今回はn個の数値をランダムに並び替えるアルゴリズム。
元ネタはこちらの記事。
chemiphys.hateblo.jp

上記はRnd関数のランダム性を利用したアルゴリズムで、出てきたSingle値の順位を付けることで結果的にその順位が重複のないランダムな数列になるというもの。

たとえば1～5をランダムに並び替えたいとする。

このようにRndを5回評価し、大きい順に順位をつける。

回数	Rnd結果	順位
1回目	0.4013743	2位
2回目	0.27828	3位
3回目	0.1604415	5位
4回目	0.1628216	4位
5回目	0.6465871	1位

この順位がそのまま2, 3, 5, 4, 1という数列になるわけだ。
なるほど、面白い。

では私はということで、あらかじめ用意した数値をランダムにシャッフルするというアルゴリズムでやってみよう。

出来たのがコレ。

Sub ShuffleCollection(c As Collection)
    Dim cc As Collection: Set cc = New Collection
    Dim m As Long
    Do While c.Count > 0
        m = Int(c.Count * Rnd + 1)
        cc.Add c.Item(m)
        c.Remove m
    Loop
    Set c = cc
End Sub

上記に、なんでもいいのでコレクションを渡すと、順番がバラバラになる。
実際にこれを使うコードを作ってみた。

Sub Main()
    Dim c As Collection: Set c = New Collection
    c.Add 1: c.Add 2: c.Add 3: c.Add 4: c.Add 5
    ShuffleCollection c
    Dim x
    For Each x In c
        Debug.Print x
    Next
End Sub

何度か実行してみると、確かにシャッフルされてるのがわかる。

仕組みとしては、最初はコレクションcに5つの要素が入ってるので、1～5の範囲でランダム値を生成してそれを別のコレクションccに入れる。コレクションcからは、削除する。するとcの要素は4つになるので、1～4の範囲でランダム値を生成して～と繰り返す。
cの要素が0になったら、ccにすべて移ってるので、Set c = cc としておしまい。

関数として非破壊的に作っても良いかな。

こんな感じか。

Function CreateShuffledCollection(c As Collection) As Collection
    Dim cc As Collection: Set cc = New Collection
    Dim i
    For i = 1 To c.Count
        cc.Add c.Item(i)
    Next
    
    Dim ccc As Collection: Set ccc = New Collection
    Dim m As Long
    Do While cc.Count > 0
        m = Int(cc.Count * Rnd + 1)
        ccc.Add cc.Item(m)
        cc.Remove m
    Loop
    Set CreateShuffledCollection = ccc
End Function

これなら元のコレクションは破壊されない。
ついでに1～5をAddするのも関数化してしまおう。

Function GetSequence(n As Long) As Collection
    Dim ret As Collection: Set ret = New Collection
    For i = 1 To n
        ret.Add i
    Next
    Set GetSequence = ret
End Function

元記事は配列だったな。。ということで配列変換も関数化する

Function ChangeCollectionToArray(c As Collection) As Variant
    Dim ret(): ReDim ret(0 To c.Count - 1)
    For i = LBound(ret) To UBound(ret)
        ret(i) = c.Item(i + 1)
    Next
    ChangeCollectionToArray = ret
End Function

これをメインコードにまとめると、こうなる。

Sub Main2()
    Dim arr: arr _
        = ChangeCollectionToArray( _
            CreateShuffledCollection( _
                GetSequence(5)))
    Dim x
    For Each x In arr
        Debug.Print x
    Next
End Sub

以上