読者です 読者をやめる 読者になる 読者になる

t-hom’s diary

主にVBAネタを扱っているブログです。

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

VBA

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

上記は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

以上

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。