[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『当選者の抽選』（DASA）
プレゼントの当選者を抽選する作業を行っています。
モノは映画のチケットで、枚数は１人最高4枚までとしています。
3枚 Aさん 3枚 Bさん 4枚 Cさん 2枚 Dさん ・ ・ ・ ・
単純に１人一枚とか、ペアチケットなら、
”=IF(RANK(A1,$A$1:$A$99)<=当選者数,"○","")”A＝(ランダム関数の列) ”=IF(RANK(A2,$A$1:$A$99)<=当選者数,"○","")”
の式で出来ると思うのですが、枚数を１〜４までバラバラに入力してあって
その中から、決まった枚数分をランダムに抽出することは出来るのでしょうか?
チケットの総数は決まっているので、抽出したときに合計がその総数と同じになるような方法はありますか？
応募枚数別に分けて、それぞれ決まった枚数分選んで合計を合わせるのが一番簡単なのでしょうか？
バージョン：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 & _
"余り０になるまで最初から抽選やり直しまっか？", 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.