[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『当選者の抽選』(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枚とかの当選も ありえるのかについても、明確にしなければなりません。
十分な検証をしたわけではありませんが、[まーまあ]さんの式では、表の上側にある人と下側にある 人とでは、当選確率が異なるように思います。間違ってたらごめんなさい。 (ちゅうねん)
おもしろそうなのでちょっとマクロで作ってみました。 興味があったらどうぞ。
【やり方】 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)
当選/落選表示やラベルはなんとなくわかりますが、肝心の抽選部分はチンプンカンプンです(--;)
でも完璧です!!ありがとうございました!!ちゅうねんさん、まーまあさんも感謝です!
(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.