［VBA］Excel でランダム抽出するマクロ

2020年4月17日 2023年6月13日

かつて予想外に速攻作成に悩んだのが、Excel VBA で一覧からの無作為（ランダム）抽選です。ランダムは追求すると難しいのですが、今回は最も簡単にして、コードを書いてみます。

設定環境

Windows版 Microsoft Excel 2013

具体的には、以下の例を処理してみます。
５つの建物（ビル）に、抽選で応募者を入居者を募る例です。
60名の応募者がいて、40名はそのまま希望通りの建物に入居できます。
残りの20名はランダムに建物を割り当てます。

建物Ａ、Ｂ、Ｃ、Ｄ、Ｅをそれぞれ建物１、２、３、４、５として数字に置き換えて処理します。

この例では、40名は確実に希望が叶いますが、残りの20名はくじ引きされますので、うまくいけば希望通りということになるだけです。
処理としては、まず、全員にランダムで建物を振り分ける、次に望みどおりになる40名をまず抽出、残りの20名はランダムのままにするという流れです。
結果としては 40名以上が希望通りの建物が割り当てられるという計算です（残り20名は抽選される）。

使用する関数１　Int()

 
a =  11.123
b = -11.123
Int(a)       ' 11 になります
Int(b)       '-12　になります

Int(n) は引数 n の小数部分を取り除いて返します。引数 n が負の数の場合は、絶対値が大きくなる方向に丸めます。
例えば、n に -11.123 を入れる場合、値が小さくなる方向（絶対値が大きくなる方向）-12 に丸めます。

使用する関数２　Rnd()

Rnd(n) は０以上１未満の乱数を返します。引数 n は省略可能です。
例えば、５～10までの整数をランダムに生成するには、以下のようなコードが定番です。

 
Int((10 - 5 + 1) * Rnd + 5)       ' ５～10までの整数

Int((最大 - 最小 + 1) * Rnd + 最小) という定番式です。
「最大 - 最小」の部分で変化させる幅を求め、Rnd でその何割を有効にするか計算して、保証する最小値を加えて結果にしています。

実際のコードを書いていく手順

Cells や Columns、Range の使用方法（書式）は、もし馴染みがない方はヘルプを参照すのるがおすすめです。一分もあれば応用まですぐ飲み込めます。

以下の作業の例では、実際に使うセルの領域は B4:D63 になります。
セル C2 にはランダムではない、そのままの抽出数を入れます。
B 列は識別 ID 列で、計算では使いません。
C 列は希望建物の番号を入力します。
D 列に抽出結果を出します。

準備としては B4:C63 にあらかじめデータを入力しておくだけです。

VBA モジュールを作成する

Excel で実際にマクロを書いていきます。

画面は Excel 2013 の例です。
デフォルトでは、「表示」タブの右端にマクロボタンがあります。

VBA プロジェクトの「標準モジュール」を作成します。

VBA のコード

"Sub PickUp_F_Click()" から "End Sub" の間に以下のコードを書きます。

 
''' 一覧から無作為に抽選するマクロ
Sub PickUp_F_Click()
	Dim Ret As Integer, i As Integer, Num As Integer, rn As Integer
	i = 0
	Columns("D").ClearContents  'D列の内容を消去します。
	Columns("D").ClearFormats   'D列の書式を消去します。
	'見出し行の行番号   ３行目
	Ret = 3
	'全60行にまずランダムで割り振ります
	i = 0
	While i < 60
		i = i + 1
		' Cells 3:C列, 4:D列
		Cells(Ret + i, 3).Copy Destination:=Cells(Ret + i, 4)

		' １～５までの数字をランダム抽出する
		' Int((最大 - 最小 + 1) * Rnd + 最小) の定番式で処理
		rn = Int((5 - 1 + 1) * Rnd + 1)

		Cells(Ret + i, 4) = rn  'D列のセルに選んだランダム数字をセット
	Wend

	i = 0
	While i < Cells(2, 3)   'セルC2に抽出したい人数を入れます
	   '見出し行の行番号
		Rett = Int((60 * Rnd) + 1) + Ret
		If Cells(Rett, 4).Value <> "*" Then
			Cells(Rett, 4) = "*"
			i = i + 1
			Cells(Rett, 3).Copy Destination:=Cells(Rett, 4)
		End If
	Wend
End

このコードを、フォームのボタンに割り当てるか、もしくは「マクロ」から実行します。

興味ある方は、VBA の基礎コースなどチェックしてみてください。

1st step のVBAプログラミングコーズをチェック