[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『抽選システムをVBAで構築したい』（もひかん）
お世話になっております。
表題の通りですが、
現在VBAで抽選システムを構築したいと考えております。
某イベントで、複数日程、複数部が発生するようなイベントがあり、
一人につき一つだけ希望日、希望部を記入してもらい、希望者の中から各部を抽選していく形になります。
イベント例）
1/1〜1/4の４日間開催
各日３部構成
１部あたり１０〜20名当選（当選数は事前に各部に設定）
抽選内容
・抽選データは別シート（抽選データシート）に記載
・抽選データ内からランダムに抽選
・当選者は別シート（当選者シート）に当選IDを付与して追記
・当選IDはmmdd＋部（2桁）＋No（シーケンス3桁）とし、設定
（例：1/1 2部に当選した4番目の当選者の場合、当選ID＝010102004）
・各部の当選数上限に達した時点でその部の抽選は終了
・抽選数が当選数に満たない部は全員当選
抽選データ列は
氏名｜住所｜TEL｜メールアドレス
とします。
当選者シートへは
当選ID｜氏名｜住所｜TEL｜メールアドレス
としたいです。
分かりにくい説明で申し訳ないですが、
ご教授いただけますと幸いです。
よろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：MacOSX ＞
半分くらい冗談のつもりで、あんまり考えず言っちゃうんですが、 例えば仮に
Sub Test()
[A1:D1].Value = [{"開催日","部","本数設定","ID"}]
[H1:M1].Value = [{"応募者","希望日","希望部","ID","SEQ","当選ID"}]
[A:A,I:I].NumberFormat = "m月dd日"
[A2:B13].Value = [{44197,1;44197,2;44197,3;44198,1;44198,2;44198,3;44199,1;44199,2;44199,3;44200,1;44200,2;44200,3}]
[C2:C13].Formula = "=RANDBETWEEN(10,20)"
[D2].Formula = "=TEXT(A2,""mmdd"")&TEXT(B2,""00"")"
[D2:D13].FillDown
[H2].Formula = "=ROW(A1)"
[I2].Formula = "=INDEX(A:A,RANDBETWEEN(2,13))"
[J2].Formula = "=RANDBETWEEN(1,3)"
[K2].Formula = "=TEXT(I2,""mmdd"")&TEXT(J2,""00"")"
[L2].Formula = "=COUNTIF(K$2:K2,K2)"
[M2].Formula = "=IF(L2<=INDEX(C:C,MATCH(K2,D:D,0)),K2&TEXT(L2,""000""),NA())"
[H2:M181].FillDown
End Sub
という１シート上で考えた場合なら、 H列の[応募者]の並び順を決める(ランダムシャッフル)という作業だけで、 内容的にはほぼ出来ちゃったりして... なんて思ってしまった^^;
あとは、VBAで「システム」っぽく見せる! ...的な 浅はかな事を想像してみたり^^; (もっと真面目な回答が付くの待った方が良いかもデス。ごめんなさい)
（白茶） 2021/06/22(火) 23:38
回答ありがとうございます。
確かに、データを整理したらこれでもできそうな気がしますね。
ただ、応募者ごとに希望日希望部は決まっているので、
希望日、希望部が一致した応募者だけでその日の部は抽選したいのです。。。
応募者データを事前に各部ごとに切り分けて、
それぞれで実施すれば出来るかもですが、
出来ればデータ整理の必要もなく出来るような方法があればいいなと思っております。
（もひかん） 2021/06/24(木) 13:27
(あぁ...なんか、まともな回答が付くのを私が邪魔しちゃってるだけかも。ごめんなさい)
>希望日、希望部が一致した応募者だけでその日の部は抽選 一応そのつもりで書いた落書きだったんですけどね... さすがにちょっと雑過ぎましたか^^;
余計な情報を削ぎ落として再掲しますと、
Sub 前提データ準備()
[A:D,F:G].Clear
[A:A].NumberFormat = "@"
[A1:D1].Value = [{"ID","本数設定","応募者数","落選数"}]
[A2:A13].Value = [{"010101";"010102";"010103";"010201";"010202";"010203";"010301";"010302";"010303";"010401";"010402";"010403"}]
[B2:B13].Formula = "=RANDBETWEEN(10,20)"
[B2:B13].Value = [B2:B13].Value
[C2].Formula = "=COUNTIF(G:G,A2)"
[D2].Formula = "=MAX(C2-B2,)"
[C2:D13].FillDown
[F1:G1].Value = [{"応募者","希望ID"}]
[F2].Formula = "=TEXT(ROW(A1),""000"")&""さん"""
[G2].Formula = "=INDEX(A:A,RANDBETWEEN(2,13))"
[F2:G201].FillDown
[G:G].NumberFormat = "@"
[F2:G201].Value = [F2:G201].Value
End Sub
というデータがあったとしたら、
Sub 抽選()
[I:M].Clear
[F:G].CurrentRegion.Copy [I:J]
[K1:M1].Value = [{"SEQ","当選ID","RandSort"}]
[K2].Formula = "=COUNTIF(J$2:J2,J2)"
[L2].Formula = "=IF(K2<=INDEX(B:B,MATCH(J2,A:A,0)),J2&TEXT(K2,""000""),""落選"")"
[M2].Formula = "=RAND()"
[K2:M201].FillDown
[M1].Select
CommandBars.ExecuteMso "SortAscendingExcel"
[M:M].Clear
[K2:L201].Value = [K2:L201].Value
[K1].Select
CommandBars.ExecuteMso "SortAscendingExcel"
[J1].Select
CommandBars.ExecuteMso "SortAscendingExcel"
End Sub
という操作で「抽選」になってんじゃないかなぁ、と思ったのです。
（白茶） 2021/06/24(木) 21:48
回答ありがとうございます。
私があまり理解しておらず申し訳ありませんでした。
新たに回答頂いたコード確認してみました。
これをちょっといじればできそうですね！
非常に助かりました！
ありがとうございました。
（もひかん） 2021/06/29(火) 21:28
ご相談があります。
先日教えていただいたコードを改変しながらやってみてるんですが、
一点教えていただきたいことがございます。
当選者の分布が最初の方レコードに偏ってきてしまっておりまして、
こちらをある程度満遍なく当選となるようにするにはどうしたらよいでしょうか。
データ数は約10万件程度あるのですが、
当選者が上位数千レコードに偏ってしまっており、
こちらの原因を教えていただけると幸いです。
お手数ですが、よろしくお願いいたします。
（もひかん） 2021/07/03(土) 22:26
>当選者の分布が最初の方レコードに偏ってきてしまっておりまして あれ? そうですか? こっちでは割とちゃんと散ってますけどね... ホント単純にRAND関数に順番決めてもらってるだけですからね。
何でしょね...?
いや、それよりも気になるのが >データ数は約10万件程度 デカい!!
例示させてもらった抽選マクロだと、シート上でCOUNTIFとか使ってるので そのデータ量はちょっとキツいと思います。(計算めちゃくちゃ待たされるでしょ)
ちょっと 「ランダムソートもVBA側でやってしまうとすれば、こんな感じかなぁ」ってのを 試に書いてみましたので載せておきます。
一応、応募者20万人のテストデータで動かしてみましたけど、 データの散り具合はRAND関数と同じ感じでした。
Sub 前提データ準備()
[A:D,F:G].Clear
[A:A].NumberFormat = "@"
[A1:D1].Value = [{"ID","本数設定","応募者数","落選数"}]
[A2:A13].Value = [{"010101";"010102";"010103";"010201";"010202";"010203";"010301";"010302";"010303";"010401";"010402";"010403"}]
[B2:B13].Formula = "=RANDBETWEEN(40,60)*100"
[B2:B13].Value = [B2:B13].Value
[C2].Formula = "=COUNTIF(G:G,A2)"
[D2].Formula = "=MAX(C2-B2,)"
[C2:D13].FillDown
[F1:G1].Value = [{"応募者","希望ID"}]
[F2].Formula = "=TEXT(ROW(A1),""000000"")&""さん"""
[G2].Formula = "=INDEX(A:A,RANDBETWEEN(2,13))"
[F2:G200001].FillDown
[G:G].NumberFormat = "@"
[F2:G200001].Value = [F2:G200001].Value
End Sub
Sub 抽選()
Dim Dic1 As Object, Dic2 As Object
Dim r As Long, v As Variant, s() As Variant, w() As Variant
Dim a As Range
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
v = [A1:B13].Value
For r = 2 To 13
Dic1(v(r, 1)) = v(r, 2)
Set Dic2(v(r, 1)) = New Collection
Next
v = [F1:G200001].Value
For r = 2 To 200001
Dic2(v(r, 2)).Add v(r, 1)
Next
[I1:J1].Value = [{"応募者","当選ID"}]
Set a = [I2:J2]
For Each v In Dic2.keys
s = ShuffleBetween(1, Dic2(v).Count)
ReDim w(1 To UBound(s), 1 To 2)
For r = 1 To UBound(s)
w(r, 1) = Dic2(v).Item(s(r))
If r <= Dic1(v) Then w(r, 2) = v & Format$(r, "_000000")
Next
a.Resize(UBound(s)).Value = w
Set a = a.Offset(UBound(s))
Next
End Sub
Private Function ShuffleBetween(iFrom As Long, iTo As Long) As Variant()
Rem 指定された範囲の整数をランダムソートした配列(添字の最小値がiFromの配列)を返す関数
If iFrom > iTo Then Exit Function
Dim Rtn() As Variant, i As Long, j As Long
Dim Coll As New Collection
For i = iFrom To iTo
Coll.Add i
Next
ReDim Rtn(iFrom To iTo)
Randomize
For i = iFrom To iTo
j = Int(Rnd * Coll.Count) + 1
Rtn(i) = Coll.Item(j)
Coll.Remove j
Next
ShuffleBetween = Rtn
End Function
（白茶） 2021/07/04(日) 01:33
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.