[[20070621143854]] 『当選者の抽選』(DASA) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『当選者の抽選』(DASA)

プレゼントの当選者を抽選する作業を行っています。
モノは映画のチケットで、枚数は1人最高4枚までとしています。

 3枚 Aさん
 3枚 Bさん
 4枚 Cさん
 2枚 Dさん
 ・   ・
 ・   ・

単純に1人一枚とか、ペアチケットなら、

 ”=IF(RANK(A1,$A$1:$A$99)<=当選者数,"○","")”A=(ランダム関数の列)
 ”=IF(RANK(A2,$A$1:$A$99)<=当選者数,"○","")”

の式で出来ると思うのですが、枚数を1〜4までバラバラに入力してあって
その中から、決まった枚数分をランダムに抽出することは出来るのでしょうか?
チケットの総数は決まっているので、抽出したときに合計がその総数と同じになるような方法はありますか?

応募枚数別に分けて、それぞれ決まった枚数分選んで合計を合わせるのが一番簡単なのでしょうか?

バージョン:Excel2003、WindowsXP


RANDBETWEEN関数を使って、総枚数からそれまでに割り当てた総枚数を引いた値を上限値に指定したら?

(まーまあ)


 どのような形で元データが構成されているのか不明ですが、
 Rand・RandBetween 関数はファイルを立ち上げる度に同じ乱数郡を
 発生させますので、ご注意を...
 (seiya)

 	A	B	
    1	Aさん	=RAND()
    2	Aさん	 :
    3	Aさん	
    4	Aさん	
    5	Bさん	
    6	Bさん	
    7	Bさん	
    8	Bさん	
    9	Cさん	
    :	 :		
 で、B列の数字の順位に沿って、総枚数分だけ当選にすればいかがでしょう。
 (ちゅうねん)

=MOD(RANDBETWEEN(0,総枚数-SUM($B$1:$B1)),最大当籤枚数+1)

A列に応募者名、B列に当籤枚数、B1セルは数字以外か空欄という想定。総枚数、最大当籤枚数は具体的な数値に置き換えるか、数値を入力しているセルのアドレスに置き換えてみてね。
(まーまあ)


まーまあさん、具体的にありがとうございます。

=MOD(RANDBETWEEN(0,400-SUM($B$1:$B1)),B2+1)

C列に数式を入れてやってみました。0と出た人はハズレだから良いとして、
当籤者には希望枚数が当たるという形にしたいのですが出来ますでしょうか?
(そもそも最大当籤枚数のところが違うのでしょうか・・・)

 A B C

 氏名 希望
 Aさん  3   1
 Bさん  3   0
 Cさん  2   3
 Dさん  4   4

   ↓

 A B C

 Aさん  3   3
 Bさん  3   0
 Cさん  2   0
 Dさん  4   4

あと、上から順番に見ていって、途中からNUM!がでてくるのですが
それまでに割り当てられた枚数を合計しても総枚数に達していないのですがこれはなぜなんでしょう?

お分かりでいたら、教えてください


 当選確率をどのように制御したいかで、考え方が変わってきます。
 1枚を希望した人も、4枚を希望した人も、同じ当選確率にするのか、それとも、4枚を希望した人は
 1枚を希望した人よりも当選確率を低く(例えば1/4に)したいのか…です。
 また、4枚希望した人は、4枚当たるか全く当たらないの二者択一なのか、1枚だけとか2枚とかの当選も
 ありえるのかについても、明確にしなければなりません。

 十分な検証をしたわけではありませんが、[まーまあ]さんの式では、表の上側にある人と下側にある
 人とでは、当選確率が異なるように思います。間違ってたらごめんなさい。
 (ちゅうねん)

ちゅうねんさん、確立は枚数に関係なく同じにしたいと思います。
また、当選者には希望枚数が当たるようにしたいです。
4枚希望の人は4枚、2枚希望は2枚で、当たらなければゼロという形です。

 おもしろそうなのでちょっとマクロで作ってみました。
 興味があったらどうぞ。

 【やり方】
 A列に氏名、B列に希望枚数だけがある状態で、実行してください。
 (1)シートタブを右クリック⇒コードを表示 に下記のコードをコピーします。
 (2)マクロを実行(※1)します。初回実行時にシートの動作準備がされます。
 (3)F2にチケットの総数を入力(最初は100が入ってます。)
 (4)再度マクロの実行(※1)をしてください。
  ※1 Alt+F8 で Sheet1!Drawing を実行(Sheet1 の部分はシート名)

 チケットの枚数や、希望枚数の分布によりチケットが残ることがありますが、
 (4)を再度実行することで再抽選になります。

 〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
 Option Explicit

 '---------------------------------
 Sub Drawing()
 '---------------------------------
    If Range("A1").Value <> "氏名" Then
        SheetInit
        MsgBox "チケット枚数を入力して、再度実行してください。"
        Range("F2").Select
        Exit Sub
    End If

    Randomize
    Dim lastNum As Long
    lastNum = Range("A" & Rows.Count).End(xlUp).Row

    Range("C2:D" & lastNum).Clear
    Range("A2:D" & lastNum).Borders.Weight = xlThin
    Dim i
    For i = 2 To lastNum
        Cells(i, "C").Value = Rnd()    '--- 乱数で抽選 0〜1 の数値を付与
 '--- 枚数によって確率を変える場合
 '---   Cells(i, "C").Value = Rnd() / Cells(i, "B").value
 '--- のようにすれば出来そう。
    Next
    Cells(lastNum + 1, "D").Formula = "=SUM(D2:D" & lastNum & ")"
    Range("F3").Value = Range("F2").Value

    MsgBox "START!!"

    Dim maxNum As Double
    Dim maxIndex As Long
 '--- チケット残数が残っている間ループ
    Do While Range("F3").Value > 0
        maxNum = 0
        maxIndex = 0
 '--- この For の部分ですでに当選した人を除いて最大の値を持つ人を検索
        For i = 2 To lastNum
            If Cells(i, "C").Value <> "当選" Then
 '--- チケット残数が希望枚数より多いなら抽選対象:なので当落線上の場合は希望枚数が少ない方がわずかに有利
                If maxNum < Cells(i, "C").Value Then
                    If Cells(i, "B").Value <= Range("F3").Value Then
                        maxNum = Cells(i, "C").Value
                        maxIndex = i
                    End If
                End If
            End If
        Next
 '--- 該当者無しの場合は終了(チケットが1枚残っていて希望枚数が2枚以上だけのようなとき)
        If maxNum = 0 Or maxIndex = 0 Then
            Exit Do
        End If
 '--- 最大値だった人が当選
        Range("F3").Value = Range("F3").Value - Cells(maxIndex, "B").Value
        Cells(maxIndex, "C").Value = "当選"
        Cells(maxIndex, "C").Font.Bold = True
        Cells(maxIndex, "C").Font.ColorIndex = 3
        Cells(maxIndex, "D").Value = Cells(maxIndex, "B").Value
    Loop

 '--- 残念ながら落選
    For i = 2 To lastNum
        If Cells(i, "C").Value <> "当選" Then
            Cells(i, "C").Value = "落選"
        End If
    Next
 End Sub
 '---------------------------------
 Private Sub SheetInit()
 '---------------------------------
    Rows(1).Insert
    Range("A1").Value = "氏名"
    Range("B1").Value = "希望枚数"
    Range("C1").Value = "結果"
    Range("D1").Value = "発送数"

    Range("F1").Value = "チケット数"
    Range("F2").Value = 100

    Union(Range("A1:D1"), Range("F1")).Interior.ColorIndex = 35
    Union(Range("A1:D1"), Range("F1:F2")).Borders.Weight = xlThin
 End Sub
 〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
 (Mook)

Mookさん、素晴らしいです!!単に抽選するだけじゃなくて、ラベルが出来て、当選/落選が表示されて色分けされるなんて!

当選/落選表示やラベルはなんとなくわかりますが、肝心の抽選部分はチンプンカンプンです(--;)

でも完璧です!!ありがとうございました!!ちゅうねんさん、まーまあさんも感謝です!

(DASA)


 使っていただけたようで、何よりです。
 機能的には変わっていませんが、不要な部分の削除と、内容が少しはわかるように
 コメントを追加しました。
 (Mook)

 Mookはんの向こうを張るワケでは決しておまへんねんけど、面白そうなんでわたしも
 よせてくらはい。
 っちゅうても概ねMookはんのパクリになっとりますけどなぁ。(笑
 ばやいによってはチケットが余る結果になると思いますんで、その処理方法をユーザー
 に委任しとります。
 シートモジュールに下のコードを貼り付けF1にチケット数と書き込んでくらはい。
 後はA2から必要なデータを書き込みます。勿論B列にもです。
 へてからF2にチケットの枚数を書き込むと結果が得られるっちゅう寸法なんですワ。
       (弥太郎)
 '--------------------------
 Option Explicit
 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, y As Long, n As Integer, uni(), uniadrs As Range
    Dim mxrow As Long, b As Integer, tbl

    Static flag As Boolean
    If Target.Count > 1 Then Exit Sub
    If Application.Intersect(Target, Range("f1:f2")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Target.Address(0, 0) = "F1" Then
        If Target = "チケット数" Then
            Range("a1").Resize(, 4) = Array("氏名", "希望枚数", "結果", "発送数")
            Union(Range("a1:d1"), Range("f1")).Interior.ColorIndex = 35
            Application.EnableEvents = True: Exit Sub
        End If
    Else
        If Not IsNumeric(Target) And Cells(2, 1) = "" Then Exit Sub
        n = Target
        Randomize
        mxrow = Range("a" & Rows.Count).End(xlUp).Row
        Cells.Borders.LineStyle = False
        Range("c2").Resize(Cells.Find("*", , , , xlByRows, xlPrevious).Row, 2).Clear
        tbl = Range("a2").Resize(mxrow - 1, 4)
        ReDim tbl_1(1 To UBound(tbl, 1))
        For i = 1 To UBound(tbl, 1)
            tbl_1(i) = Rnd
        Next i
        For i = 1 To UBound(tbl, 1)
            y = Application.Match(Application.Large(tbl_1, i), tbl_1, 0)
            If n - tbl(y, 2) < 0 Then
                If Not flag Then
                    MsgBox "チケットが " & n & " 枚余りましたが" & vbLf & _
                            "余り0になるまで最初から抽選やり直しまっか?", 1
                    If vbYes Then
                        flag = True
                        Application.EnableEvents = True
                        Range("f2") = Range("f2").Value
                        Exit Sub
                    Else
                        Exit For
                    End If
                Else
                    Application.EnableEvents = True
                    Range("f2") = Range("f2").Value
                    Exit Sub
                End If
            Else
                ReDim Preserve uni(b)
                tbl(y, 3) = "当選"
                tbl(y, 4) = tbl(y, 2)
                uni(b) = Cells(y + 1, 3).Address(0, 0)
                b = b + 1
                n = n - tbl(y, 2)
            End If
            If n <= 0 Then Exit For
       Next i
    End If
    Set uniadrs = Union(Range(uni(0)), Range(Join(uni, ",")))
    uniadrs.Font.ColorIndex = 3
    Cells(1, 1).Resize(mxrow, 4).Borders.LineStyle = True
    Cells(2, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)) = tbl
    Application.EnableEvents = True
    flag = False
 End Sub


 学校の大御所の登場、光栄です。

 EXCEL の関数は弱いのですが、Large や Match を使用すると随分シンプルになるのですね。
 配列を使うのも知ってはいるものの、億劫でついついセルでやってしまいましたが、
 見た目にはパッと結果が出てよいですね(途中の乱数も画面に出ませんしね)。

 再抽選を確認するのも親切ですね。
 たいへん参考になりました。
 (Mook)

 いやぁ、Mookはんに望外のお褒めの言葉を頂いてそれこそ公園の突き当たり、あ、イヤ 光栄の至りですワ(笑
 いつもながら相変わらずのご活躍、ちゃんと目ぇに止めてまっせぇ。
 なぁに、あんた、これはMookはんのアイディアを頂戴したマクロなんで、殊勲甲はMookはんに変わりはありまへんねんで、えぇ、えぇ。
      もう、呑んだ〜(弥太郎)

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.