ヒガサラblog

サラリーマン向けに、仕事を効率良く進めていくための方法についてご紹介しています。プログラミングから対人スキルまでを幅広く掲載中。

ヒガサラblog

【VBA】エクセルであみだくじ!面倒な抽選作業をデジタル化!

f:id:yshgs_elec:20200917223554j:plain

■社長がスポーツ観戦チケットをくれた!

■取引先から贈答品をいただいた!

こんなとき、欲しい人が集まって、ジャンケンやあみだくじをやっている職場は多いのではないでしょうか?

 

しかし、このご時世です。

なかなか人が集まるのも大変ですよね。

 

というわけで、この記事では、エクセルを使った抽選マクロの作り方をご紹介します。

 

この記事に書かれていることをコピーするだけで簡単に作成できます。

ぜひ職場の共有フォルダにひとつ作っておきましょう!

 

 

エクセル抽選マクロの作り方

今回は以下の仕様で作成しています。

■エントリーする人数は何人でもOK

■当選者数も自由に設定可能

それでは作成手順に移っていきます。

 

エクセルシートを整える

まずは以下の画像を参考にエクセルシートを整えます。

f:id:yshgs_elec:20200917215028j:plain

 

VBAコードを記述

次にVBAコートを記述していきます。

コードの記述方法がわからない方は以下の記事を参考にしてください。

www.higashisalary.com

 

準備ができたら以下のコードをコピーして記述してください。

 


Sub chuusen()
Application.ScreenUpdating = False
Dim num_tousen As Integer
Dim i, j, k, m As Integer
Dim base_num As Variant '乱数の割り当て i = 1 Do Until Cells(3 + i, 1) = "" Cells(3 + i, 2) = Int(Rnd() * 100000) i = i + 1 Loop '当選者の選択 For num_tousen = 1 To Cells(2, 1) base_num = 0 j = 1 Do Until Cells(3 + j, 1) = "" If IsNumeric(Cells(3 + j, 2)) = True Then If Cells(3 + j, 2) > base_num Then base_num = Cells(3 + j, 2) Else End If Else End If j = j + 1 Loop k = 1 Do Until Cells(3 + k, 1) = "" If Cells(3 + k, 2) = base_num Then Cells(3 + k, 2) = "当選" Else End If k = k + 1 Loop Next '乱数削除 m = 1 Do Until Cells(3 + m, 1) = "" If IsNumeric(Cells(3 + m, 2)) = True Then Cells(3 + m, 2) = "" End If m = m + 1 Loop Application.ScreenUpdating = True End Sub

 

抽選ボタンの作成

コードが記述できたら次は抽選ボタンを作成していきます。

ボタンの作成方法については以下の記事を参照ください。

www.higashisalary.com

 

私の場合はこんな感じにボタンを配置しました。

f:id:yshgs_elec:20200917215517j:plain

 

実行結果の確認

これで完成です。

さっそくマクロを実行してみましょう!

 

いざ実行!

 

f:id:yshgs_elec:20200917215745j:plain

 

きちんとA2セルに入力された当選者数の数だけ、当選者が出ていますね。

何度やってもやってもランダムに当選者が抽選されるはずです。
 

マクロ有効ブックとして保存

 動作確認まで終わったら、しっかりと保存しておきましょう。

手順は以下の通りです。

①ファイルタブを選択

②名前をつけて保存

③保存場所を選択

④ファイル名を入力

⑤マクロ有効ブックを選択(下の画像を参考)

f:id:yshgs_elec:20200917220211j:plain

⑥保存をクリック

 

これで次回からは最初から抽選が行えますね。

 

当選確率の検証

作成方法はわかっていただけたと思いますが、

「本当に公平に抽選されるの?」

こんなことを考えている人も多いと思います。

 

というわけで、このマクロの公平性を確認する手法についてもご紹介しておきます。

 

やることは非常にシンプル。

■当選者を2人に設定

■さきほど作った抽選マクロを10000回実行する

⇒各自の当選回数をカウントしておく

■各自の当選回数を抽選回数(10000×2)で割る

こんな手順で当選確率が公平であるかを確認していきます。

 

検証用VBAコード

とはいえ、10000回も手動でやってられませんので、これもマクロで自動化しておこないます。

以下が当選回数を数えながら、10000回抽選マクロを実行するコードです。

 


Sub kakuritu_test()
Dim i,j As Integer For i = 1 To 10000 Call chuusen j = 1 Do Until Cells(3 + j, 1) = "" If Cells(3 + j, 2) = "当選" Then Cells(3 + j, 3) = Cells(3 + j, 3) + 1 End If j = j + 1 Loop Next End Sub

 

 ※VBA実行中に他のVBAコードを動かすには

Call  作ったマクロの名前

で実行できますので、覚えておくと良いでしょう。

 

当選確率検証コードが書けた方は実際に実行してみましょう!

 

再び、いざ実行!

※数分かかりますので実行する際はご注意ください。 

 

当選確率の計算結果

以下がマクロで10000回実行したときの当選回数の集計結果と、それを抽選回数で割った、各参加者の当選確率の結果です。

今回は11人の参加者で行いましたので、当選確率は

100÷11≒9.09% です。

多少のばらつきはあるものの、ほぼ期待値通りの結果となっており、公平に抽選できていると言っていいのではないでしょうか。

f:id:yshgs_elec:20200917221332j:plain

 

※厳密にいうと、このマクロは上に書いてある人の方が極々わずかではありますが、当選確率が高くなっています。

その理由がわかれば、あなたはプログラミングの才能ありです。

 

終わりに

というわけで、今回は抽選マクロの作り方をご紹介しました。

このご時世でなくても、景品の抽選なんて、わざわざ人が集まってやることでもないので、ぜひこの記事を参考にデジタル化を行っておきましょう。

 

このように、このブログでは、エクセル(VBA)を中心に、様々な効率化スキルを紹介しています。

■日々の業務効率を上げたい。

■早く帰って子供と遊びたい。

こんな人はぜひ他の記事も読んでみてください。

 

また、VBAを使ってこんなことがしたいんだけど、やり方がわからない、という悩みを抱えているかたは、お気軽にコメント欄から質問してください。

私にわかる範囲であればご協力いたします。(もちろん無料です。)

 

最後に・・・

このブログを応援してあげても良いよ、という方は以下のボタンをポチっていただけると嬉しいです。

にほんブログ村 IT技術ブログ VBAへ
にほんブログ村

にほんブログ村 IT技術ブログへ
にほんブログ村

 

Twitterもやっていますので、興味があれば覗いてみてください。

それではまた!!

 

オススメ記事

www.higashisalary.com

www.higashisalary.com