【VBA】複数データを重複しないでランダムに抜き出す

【VBA】重複しないでランダムに抜き出す

今回はあるデータセットから、複数データを重複しないでランダムに抜き出す VBA マクロを作ってみます。まずその練習として、4変数配列を用意して”A”, “B”, “C”, “D” という文字列を格納できる Sub プロシージャを作っておきます。

Option Base 1

Sub Sorting()

　　Dim i As Integer, rd As Integer
　　Dim x As String
　　Dim mydata(4) As String

　　mydata(1) = "A"
　　mydata(2) = "B"
　　mydata(3) = "C"
　　mydata(4) = "D"

　　For i = 1 To 4
　　　　Randomize
　　　　'1～ 4の整数を得ます
　　　　rd = Int(4 * RND + 1)
　　　　'xに元のデータを保存しておきます
　　　　x = mydata(i)
　　　　'配列データを他の配列データと交換します
　　　　mydata(i) = mydata(rd)
　　　　'保存しておいたデータを交換先に入れます
　　　　mydata(rd) = x
　　Next i

　　'配列データを並べます
　　For i = 1 To 4
　　　　Debug.Print mydata(i);
　　Next i

End Sub

Sorting() を実行するたびに、イミディエイトウィンドウに CDBA, ACDB などが無作為に表示されます。要となるのは

x = mydata(i)

という部分です。mydata(i) と mydata(rd) の間で直接データの交換はできないので、いったん x という変数を中継して交換を実行しています。言われてみれば簡単なんだけど、こばとは全然思いつかなかったので、こちらのサイト を参考にさせていただきました。どうもありがとうございます。
 
というわけで、この配列交換プロシージャを応用して、あるリストから無作為に複数データを重複なしで抜き出すマクロを作ってみました。まずは 10 個のデータを用意してください。適当なのがなければ下のデータをコピーしてね。

コピーしたデータはセル B2 にぺったんこと貼りつけてくださいな。それではマクロを書いてみましょう。

'[VBA] 複数データを重複なしでランダムに抜き出す

Option Base 1

Sub Random_choice()

　　Dim i As Integer, rd As Integer
　　Dim x As String

　　'10 個の要素をもつ配列を文字列型で宣言しておきます
　　Dim mydata(10) As String

　　'B3 から B12 のデータを配列に入れます
　　For i = 1 To 10
　　　　mydata(i) = ActiveSheet.Cells(i + 2, 2)
　　Next i

　　'配列データを無作為に交換します
　　For i = 1 To 10
　　　　Randomize
　　　　rd = Int(10 * RND + 1)
　　　　x = mydata(i)
　　　　mydata(i) = mydata(rd)
　　　mydata(rd) = x
　　Next i

　　'D3～D5 に mydata(1)～mydata(3)を書き込みます
　　For i = 3 To 5
　　　　ActiveSheet.Cells(i, 4) = mydata(i)
　　Next i

End Sub

Random_choice() を実行すると下の図のようにランダムに 3 人が選び出されますよ。
 

データをテーブル形式に変えておけば、より汎用性の高いマクロを作ることができます。[ホーム] ⇒ [テーブルとして書式設定]から 名簿データをテーブルに変えて、[テーブルツール] でテーブル名を「名簿」としてください。同じようにして選出データも「選出」というテーブルにしておきます。それから次のようなコードを書いてみましょう。

'[VBA] テーブルから重複しないでランダムに抜き出すマクロ

Option Base 1

Sub Random_choice_table()

　　Dim i As Integer, ct As Integer, rd As Integer
　　Dim x As String
　　Dim mylist As ListObject
　　Dim outrange As Range
　　Dim mydata() As String

　　Set mylist = ActiveSheet.ListObjects("名簿")
　　Set listrange = ActiveSheet.ListObjects("名簿").DataBodyRange
　　Set outrange = ActiveSheet.ListObjects("選出").DataBodyRange

　　'名簿のデータ数を数えます
　　ct = mylist.ListRows.Count

　　'配列の要素数を決めます
　　ReDim mydata(ct)

　　'配列に名簿のデータを放り込みます
　　For i = 1 To ct
　　　　mydata(i) = listrange.Cells(i, 1)
　　Next i

　　'配列データをシャッフルします
　　For i = 1 To ct
　　　　Randomize
　　　　rd = Int(ct * RND + 1)
　　　　x = mydata(i)
　　　　mydata(i) = mydata(rd)
　　　　mydata(rd) = x
　　Next i

　　For i = 1 To 3
　　　　outrange.Cells(i, 1) = mydata(i)
　　Next i

End Sub

Random_choice_table() の実行結果は先ほどと同じようになります。
 

 
Random_choice_table() は（名簿をテーブル形式にしておけば）データ数がいくつであっても使えます。InputBox 関数なんかを使ってちょこっと改造すると、抜き出す人数もユーザーさんが入力できるようになります。掃除当番や班を決める時にも使えますよ。