抽選を実行するVBA 連続抽選、単発抽選、重複回避

tyusenjikkoueyecatch

エクセルVBA抽選の実行コードを組み立て方を解説します。
抽選方法と結果の表示にバリエーションを設定できますので、抽選のイベント性をより高くすることができます。

こんにちは、じゅんぱ店長（@junpa33）です。

今回のエクセルVBA抽選ソフトの作り方の紹介は、「抽選実行コードの仕組み」づくりです。

一つの抽選イベントで、複数（6つ）の賞の抽選が出来るようにしたいと思います。

抽選実行のVBAの組み立て概要

tyusentyujikkop002

抽選の実行プログラムの中で、

実行時にさせたいことは大きく次の6点になります。

そしてこの記事では、②から⑥の項目に関して説明していきます。

これらはModule2へのコード記述になります。

  1.  ユーザーフォームで、抽選作業のすべてをコントロールする
  2.  一つの抽選イベントで６つの賞を設定でき、個別に抽選作業をすることが出来る
  3. 1つの賞の抽選に対して連続（一度にすべて）、単発（一回のみの抽選）の2種類の抽選方法を選択できる
  4. 抽選表に「抽選中」「当選」が視認できるようにする
  5.  先に当選していた場合は、次の当選は無効にする
  6. 設定した賞の進行状態を上部に表示する
目次へ戻る

作成するプロシージャー

tyusentyujikkop003

今回のエクセルVBAコードは「Module2」に記述します。

「Module2」に記述する全コードは次のようになります。

  1. プロジェクト内とモジュール内の変数宣言
  2.  抽選の実行プロシージャー
  3.  連続抽選のためのプロシージャー
  4.  単発抽選のためのプロシージャー
  5. 重複当選チェックのプロシージャー
  6. 当選番号リストアップのプロシージャー
  7. 当選者集計のプロシージャー

①プロジェクト内とモジュール内の使用変数の宣言

プロジェクト内とこのModele2内で使う変数を宣言します。

VBA
Option Explicit
'Windows API Sleep関数の使用宣言
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
'最終行の行数
    Public Arow, SYOrow, SETrow As Long
'賞名
    Public VName As String
'当選本数
    Public Hon, Zan, Cot As Long
'抽選表のセル行列位置
    Dim Vc, Vr As Long
'重複当選指標、セル色コード
    Dim Jfk, Col As Long
'Sleep関数の時間指定
    Dim time As Long
'重複チェック指標
    Dim MR As Long
宣言変数
  • Arow・・・・　B列の最終行、　SYOrow・・・・　A列の最終行、　SETrow・・・・　A列とB列の最終行
  • VName・・・・　6つの賞名
  • Hon・・・・　各賞の当選本数、　Zan・・・・　各賞の当選残数、　Cot・・・・　当選順位
  • Vc・・・・　抽選表のセル位置（列）、　Vr・・・・　抽選表のセル位置（行）
  • Jfk・・・・　重複当選が発生した回数をカウント、　Col・・・・　抽選表の元のセル色を保存
  • time・・・・　Sleep関数の休止時間を規定する
  • MR・・・・　重複当選になるかどうかの判断指標

変数宣言の方法についてはこちらを参考にしてください。

vbasengeneyecatch 宣言方法で変数の適用範囲を変える エクセルVBA

②抽選の実行プロシージャー

抽選を実行する本体のプロシージャーになります。

そのほか部品化された他のプロシージャーがここから呼び出されていきます。

宣言変数
  • SelT・・・・　Falseなら単発抽選、Trueなら連続抽選
  • YN・・・・　「0か1」抽選方法の識別に使う　Module3で規定
  • PrN()・・・・　賞名　Module3で規定
  • PrQn()・・・・　当選本数　Module3で規定
  • ST・・・・　ユーザーフォームの６つの賞の抽選ボタンの識別

　　　　コード設計のポイント

抽選イベントで6つの賞を抽選できるようにし、さらにそれぞれに単発抽選と連続抽選を設定しています。

このプロシージャーは、ユーザーフォームの合計12個のコマンドボタンから12種類の抽選実行命令が入ってきます。

実行条件の差異分岐を、簡潔にコード記述するため、If条件文ではなく、Select Case文を使っています。

各抽選実行ボタンで共通のコード処理となる部分は、（自分としての）可読性を考慮して、部品プロシージャー化しています。

（どこまで部品化するかは個人的所見があると思います。）

各賞の抽選状況の集計を上部に表示します。

当選者に対して、賞名と当選順位、当選者番号を当選順に表示していきます。

tyusentyujikko001_kai

以下の記事を参考にしてください。

vbaselectcaseeyecatch Select Case 条件分岐の使い方。ステートメントの基本 vbawithstateeyecatch With～End Withの使い方。VBAコードを簡潔に記述する VBAValeyecatch Val関数はデータ型不一致の解決策。文字列型から数値型へ vbamideyecstch Mid関数・Right関数・Left関数は文字列中の文字を切り出す vbalastcelleyecatch データ入力済セルの最終行番号を取得する vbafontsyseyecatcha Fontプロパティで文字装飾操作をする vbacalleyecatch 部品化プロシージャーでCallステートメントは必須 vbacellspaintbackeyecatch 「塗りつぶし」背景色をVBAで記述する
HTML
Sub 抽選会()
'SelTで単発抽選かどうかっを判断します。
    Dim SelT As Boolean
        Set TYsheet = Worksheets("抽選会場")
        TYsheet.Select
        If Range("A1") = "" Then Exit Sub
        Arow = Cells(Rows.Count, 2).End(xlUp).Row
        Range("C1").Clear
        Ar = val(Mid(Range("B2"), 2))
    'Parは参加人数
        Par = val(Mid(Range("J3"), 7))
        VName = ""
        Jfk = 0
    'YNは抽選方法の識別標識ですModule3で規定
        If YN = 0 Then
            SelT = False
        ElseIf YN = 1 Then
            SelT = True
        End If
    'PrN()とPrQn()はModule3.抽選項目登録で設定しています
    'STは設定ナビの12個の抽選ボタンに値が割り振られています
    'PrN()は賞名、PrQn()は当選本数　Module3で規定しています
        Select Case ST
            Case Is = 1
                VName = PrN(1)
                Hon = PrQn(1) - Range("B5")
            Case Is = 2
                VName = PrN(2)
                Hon = PrQn(2) - Range("B6")
            Case Is = 3
                VName = PrN(3)
                Hon = PrQn(3) - Range("B7")
            Case Is = 4
                VName = PrN(4)
                Hon = PrQn(4) - Range("B8")
            Case Is = 5
                VName = PrN(5)
                Hon = PrQn(5) - Range("B9")
            Case Is = 6
                VName = PrN(6)
                Hon = PrQn(6) - Range("B10")
        End Select
        SYOrow = Cells(Rows.Count, 1).End(xlUp).Row
    '抽選中の賞名を当選一覧で表示するセル位置を決める
        If VName <> Cells(SYOrow, 1) Then
            If Arow = SYOrow Then
                SETrow = 0
            ElseIf Arow > SYOrow Then
                SETrow = Arow - SYOrow
            ElseIf Arow < SYOrow Then
                SETrow = -1
            End If
            With Range("A" & SYOrow + 1 + SETrow)
                .Value = VName
                .Font.Size = 13
                .Font.Bold = True
                .Font.ColorIndex = 3
            End With
        End If
        If SelT = True Then
            Call Module2.連続抽選
        ElseIf SelT = False Then
            Call Module2.単発抽選
        End If
    '抽選完了表示
        With Range("A2")
            .Value = "抽選完了"
            .Font.Bold = True
            .Font.Size = 15
            .Font.ColorIndex = 2
            .Interior.ColorIndex = 53
        End With
    '重複当選表示
        With Range("C2")
        .Value = "重複当選　" & Jfk & " 回発生しました。"
            .Font.Bold = True
            .Font.Size = 13
        End With
    '当選未決数表示
        Select Case VName
            Case Is = PrN(1)
                Range("C5") = PrQn(1) - Range("B5")
            Case Is = PrN(2)
                Range("C6") = PrQn(2) - Range("B6")
            Case Is = PrN(3)
                Range("C7") = PrQn(3) - Range("B7")
            Case Is = PrN(4)
                Range("C8") = PrQn(4) - Range("B8")
            Case Is = PrN(5)
                Range("C9") = PrQn(5) - Range("B9")
            Case Is = PrN(6)
                Range("C10") = PrQn(6) - Range("B10")
        End Select
End Sub

③連続抽選のためのプロシージャー

ユーザーフォームで連続抽選ボタンを押していた場合に起動します。

宣言変数
  • j・・・・　カウンター変数
  • Vicb・・・・　排出乱数の整数部分
  • Vcb・・・・　Vicbから計算したセル位置（列）
  • Vrb・・・・　Vicbから計算したセル位置（行）
  • OPr・・・・　連続抽選をするスピード　Module3で規定

　　　　コード設計のポイント

乱数から抽選表のセル位置を決定する計算

輩出した乱数の整数部分が 97 の場合

Ar = 12 ,    Vicb = 97

Vcb = Vicb \ Ar なので

Vcb = 8

Vrb = Vicb Mod Ar なので

Vrb = 1 

If Vrb > 0 Then
　Vcb = Vcb + 1　なので

Vcb = 9 , Vrb = 1 となり

セル位置は、Cells(4,12)になります。（会長賞の当選セル）

vbarndeyecatch Rnd関数で乱数を取得。デフォルトでは使えない戻り値の加工 vbaintfixeyecatch Int・Fix・Abs・Sign関数で数値の整数部分を完全分離
VBA
Sub 連続抽選()
'カウンター変数
    Dim j As Long
'乱数とその加工値
    Dim Vicb, Vcb, Vrb As Long
    '乱数発生のパターン化防止
        Randomize
        Range("A2,C2,F1").Clear
    'OPrは連続抽選スピード　Module3で規定
        Select Case OPr
            Case Is = 0
                time = 250
            Case Is = 1
                time = 300
            Case Is = 2
                time = 200
            Case Is = 3
                time = 100
        End Select
    '抽選の本数分ループする
        For j = 1 To Hon
            Vicb = Int(Rnd * Par + 1)
            Vcb = Vicb \ Ar
            Vrb = Vicb Mod Ar
            If Vrb > 0 Then
                Vcb = Vcb + 1
            ElseIf Vrb = 0 Then
                Vrb = Ar
            End If
            Col = Cells(Vrb + 3, Vcb + 3).Interior.Color
            With Cells(Vrb + 3, Vcb + 3)
                .Interior.ColorIndex = 6
            Sleep time
                .Interior.Color = Col
            End With
            Vc = Vcb
            Vr = Vrb
            Call Module2.重複当選チェック
        '重複当選していなければ、このコードを実行
            If MR = 0 Then
                With Range("F1")
                    .Value = "只今の番号は、" & Cells(Vr + 3, Vc + 3) _
                        & "　が当選です。"
                    .Font.Bold = True
                    .Font.Size = 13
                End With
            End If
        Next j
        Zan = Hon - Jfk
        Call Module2.当選者集計
End Sub

④単発抽選のためのプロシージャー

ユーザーフォームで単発抽選ボタンを押していた場合に起動します。

宣言変数
  • i・・・・　カウンター変数
  • Vica・・・・　排出乱数の整数部分
  • Vca・・・・　Vicaから計算したセル位置（列）
  • Vra・・・・　Vicaから計算したセル位置（行)
  • VCount・・・・　抽選の点滅回数

　　　　コード設計のポイント

乱数から抽選表のセル位置を計算するのは、連続抽選の場合と同じです。

抽選スピードを変化させます。

点滅数が増えるほど点滅スピードが遅くなる設計にします。

VBA
Sub 単発抽選()
'カウンター変数
    Dim i As Long
'乱数とその加工値
    Dim Vica, Vca, Vra As Long
    Dim VCount As Long
    '乱数発生のパターン化防止
        Randomize
    'OPkは抽選の点滅回数　Module3で規定
        Select Case OPk
            Case Is = 0
                VCount = 15
            Case Is = 1
                VCount = 5
            Case Is = 2
                VCount = 10
            Case Is = 3
                VCount = 20
        End Select
        Range("A2,C2,F1").Clear
    '抽選の点滅回数分ループする
            For i = 1 To VCount
        '抽選スピードを選択する
                Select Case OP
                    Case Is = 0
                        time = 500 * 0.2 * i
                    Case Is = 1
                        time = 500 * 0.3 * i
                    Case Is = 2
                        time = 300 * 0.3 * i
                    Case Is = 3
                        time = 150 * 0.3 * i
                End Select
                Vica = Int(Rnd * Par + 1)
                Vca = Vica \ Ar
                Vra = Vica Mod Ar
                If Vra > 0 Then
                    Vca = Vca + 1
                ElseIf Vra = 0 Then
                    Vra = Ar
                End If
    'セル色を変数Colに保存する
                Col = Cells(Vra + 3, Vca + 3).Interior.Color
                With Cells(Vra + 3, Vca + 3)
                    .Interior.ColorIndex = 6
                    Sleep time
                    .Interior.Color = Col
                End With
                Range("F1").Value = "只今の番号は、" & Cells(Vra + 3, _
                    Vca + 3) & "　です。"
            Next i
    '抽選の最後のセル位置を保存する
        Vc = Vca
        Vr = Vra
        Call Module2.重複当選チェック
        With Range("F1")
            .Value = "当選の番号は、" & Cells(Vr + 3, Vc + 3) & "　です。"
            .Font.Bold = True
            .Font.Size = 13
        End With
        If Jfk = 1 Then
            Zan = 0
        Else
            Zan = 1
        End If
        Call Module2.当選者集計
End Sub

⑤重複当選チェックのプロシージャー

重複当選が無いように設定する部品プロシージャーです。

宣言変数
  • TRange・・・・　当選者ID表示セル
  • Jf・・・・　重複当選メッセージの表示を指示する

　　　　コード設計のポイント

重複当選メッセージが表示されるたびにコード進行がストップします。

連続抽選の場合は邪魔者になることがありますので、表示しない設定を出来るようにします。

vbamatcheyecatch001 VBAで使うMatch関数 活用度アップでテッパン関数に！
VBA
Sub 重複当選チェック()
'当選者ID表示セル
    Dim TRange As Range
        Arow = Cells(Rows.Count, 2).End(xlUp).Row
        Set TRange = Range(Cells(11, 3), Cells(Arow, 3))
        On Error Resume Next
    'Match関数で、すでにID番号が存在するかどうかを調べる
        MR = WorksheetFunction.Match(Cells(Vr + 3, Vc + 3), TRange, 0)
    '存在する場合としない場合の切り分け
        If MR = 0 Then
            Call 当選番号リストアップ
        ElseIf MR <> 0 Then
        'Jfは重複当選メッセージを表示するかどうかの分岐指標
            If Jf = 0 Then
                MsgBox "重複当選がありました。" & vbCrLf & "重複当選番号は、" _
                    & Cells(Vr + 3, Vc + 3) & " です。"
            ElseIf Jf = 1 Then
            End If
            Cells(Vr + 3, Vc + 3).Interior.ColorIndex = 43
            Jfk = Jfk + 1
            On Error GoTo 0
            MR = 0
        End If
End Sub

⑥当選番号リストアップのプロシージャー

当選者を表示するための部品プロシージャーです。

宣言変数
  • Vc・・・・　抽選表のセル位置（列）、　Vr・・・・　抽選表のセル位置（行）
  • Arow・・・・　B列の最終行、　SYOrow・・・・　A列の最終行
  • Cot・・・・　当選順位
vbaoffseteyecatch Offsetプロパティは指定範囲を移動させる
VBA
Sub 当選番号リストアップ()
        With Cells(Vr + 3, Vc + 3)
            .Interior.ColorIndex = 6
        Sleep time
            .Interior.ColorIndex = 43
        End With
    '最終行番号の最新のものを再取得する
        Arow = Cells(Rows.Count, 2).End(xlUp).Row
        SYOrow = Cells(Rows.Count, 1).End(xlUp).Row
        If Arow = 11 Then
            Cot = 1
        Else
            Cot = Cells(Arow, 2) + 1
        End If
    'リストアップ表示する
        If Range("B" & Arow + 1) = "" Then
            Range("B" & Arow + 1) = Cot
            Range("C" & Arow + 1) = Cells(Vr + 3, Vc + 3)
        ElseIf Range("B" & Arow + 1) <> "" Then
            Range("B" & Arow + 1).Offset(1) = Cot
            Range("C" & Arow + 1).Offset(1) = Cells(Vr + 3, Vc + 3)
        End If
        Range("A2").Select
    '上部に現在の当選順位を表示する
        With Range("A2")
            .Value = Cot
            .Font.Bold = True
            .Font.Size = 15
            .Font.ColorIndex = 30
            .Interior.ColorIndex = 44
        End With
End Sub

⑦当選者集計のプロシージャー

現時点での各賞の当選者数を表示します。

宣言変数
  • PrN()・・・・　賞名　Module3で規定
  • VName・・・・　6つの賞名
  • Zan・・・・　各賞の当選残数
VBA
Sub 当選者集計()
         Select Case VName
            Case Is = PrN(1)
                Range("B5") = Range("B5") + Zan
            Case Is = PrN(2)
                Range("B6") = Range("B6") + Zan
            Case Is = PrN(3)
                Range("B7") = Range("B7") + Zan
            Case Is = PrN(4)
                Range("B8") = Range("B8") + Zan
            Case Is = PrN(5)
                Range("B9") = Range("B9") + Zan
            Case Is = PrN(6)
                Range("B10") = Range("B10") + Zan
        End Select
End Sub

抽選の実行プロシージャー「抽選会」のCall呼び出し関係図

全体として、部品プロシージャーをこのように配置しています。

Sub 抽選会()
　　⌊___連続抽選
　　　　　　⌊__重複抽選チェック
　　　　　　　　　　⌊__当選番号リストアップ
　　　　　　⌊__当選者集計

　　⌊___単発抽選
　　　　　　⌊__重複抽選チェック
　　　　　　　　　　⌊__当選番号リストアップ
　　　　　　⌊__当選者集計
End Sub
目次へ戻る

抽選の実行コードの組み立て　まとめ

tyusentyujikkop004

抽選の実行について、今回はいろんなパターンを設定しました。

そのため、エクセルVBAコード上の条件分岐が多くなっています。

バリエーションのある抽選方法にしましたので、抽選のイベント性をより高めることが出来ると思います。

たくさんの条件分岐があって、煩雑になってしまうエクセルVBAのコード組み立てでは、

プロシージャーを部品化して本体（親）プロシージャーを整理整頓・簡潔化していきます。

けれどもただ、整理整頓・簡潔化と言っても、

自分（製作者）が、後で修正やメンテナンスしやすいレベルのものにしておくことが重要です。

むやみやたらと整理整頓・簡潔化行ったのでは、実務上逆に分かりずらいものになることがありますので注意が必要です。

エクセルVBAを独習するのに参考書は欠かせません。 参考書選びは自分に合った「相棒」にできるものを選んでいきたいです。

vbastudyeyecatch2 エクセルVBAの独習でおすすめ参考書を7冊選ぶ。良書との出会いは大切です

今回の記事はここまでです。   最後までご覧いただき有難うございました。

エクセルVBA最速理解で必要な知識を集めよう！

エクセルVBA業務ツールで日常の業務改善を行いましょう。

＜記事内容についての告知＞

VBAコードの記述記事においては、その記述には細心の注意をしたつもりですが、掲載のVBAコードは動作を保証するものではりません。 あくまでVBAの情報の一例として掲載しています。 掲載のVBAコードのご使用は、自己責任でご判断ください。 万一データ破損等の損害が発生しても当方では責任は負いません。

目次へ戻る

アンケートでポイ活しよう!!

アンケートに答えれば答えるほど ”使える” ポイントがたまります。

NTTコム サーチ

af_banner01

Dstyle web

dstyleweb_logo
dstyle_320x50-min

前の記事

extyusenranhyoeyecatch
エクセルVBAで抽選表を作成 人数でサイズを変更できる

次の記事

抽選作業を操作できるユーザーフォームを作成する
tyusenuformeyecatch