[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロを使っての抽選作業』（pk）
いつも大変お世話になっております。
A列に数万件のIDがあり、人によって10倍、20倍など当選確率が違うためB列に当選確率の数字が入ってます。
（当選人数はその月によって違うのでC1などに当選人数を入力するなど
出来たらと思っております。）
こちらをマクロで抽選できないかと思っておりますが
出来ますでしょうか？
乱数を使って関数でやっているのですが重くて動きが遅いので
マクロで出来たらと思っております。
お手数ですがご教示頂きたく宜しくお願い致しますm(__)m
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
IDが15件しかないとして、サンプルを示して頂けませんか？
どんな形の結果図になるのかも知りたいので。
（半平太） 2016/12/21(水) 12:25
A B C D 1 ID 当選倍数 当選人数 当選者 2 audneo12357ecnud 1 2 cndi238497nei 3 234689 10 rjhw5730jec303 4 cndi238497nei 20 5 123094857 3 6 sra876 1 7 fnei92jd8hd0 3 8 skf872njf0w9sw87w9 5 9 rjhw5730jec303 14 10 jie99873 1 11 pwo034 4 12 fjieuw46wf83w 5 13 274956 23 14 3385656 1 15 r9ewj8 3
半平太様
早速ご返信頂きありがとうございます！
このような感じではいかがでしょうか？
結果の表示はこだわりはありません。
お手数をおかけしますがご教示宜しくお願い致しますm(__)m
（pk） 2016/12/21(水) 13:06
Sub test()
Dim i As Long
Dim j As Long
Dim iw As Long
Dim iR As Long
Dim iNin As Long
iNin = Range("C2")
Range("D2", Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To Val(Cells(i, "B").Value)
iR = iR + 1
Cells(iR, "E").Value = Cells(i, "A").Value
Next j
Next i
Randomize
For i = 2 To iNin + 1
iw = Int(Rnd() * iR) + 1
Cells(i, "D").Value = Cells(iw, "E").Value
Next i
End Sub
（???） 2016/12/21(水) 13:14
この「確率」の意味ですが・・・
運が10倍いいけど、当選回数は１回ですよね？
それとも、運が良ければ、2回でも3回でも当たるんですか？
（半平太） 2016/12/21(水) 13:58
<結果図> 行 ________A________ ____B____ ____C____ ______D______ 1 ID 当選倍数 当選人数 当選者 2 audneo12357ecnud 1 2 234689 3 234689 10 cndi238497nei 4 cndi238497nei 20 5 123094857 3 6 sra876 1
シートモジュールに貼り付け ↓
Sub Bingo()
Dim dicT As Object
Dim 応募者数, 延べ人数, 当選人数, 当選倍率
Dim 該当POS As Long
Dim rowNum As Long
Dim Ladder()
Dim rngLadder As Range
Dim IDval
応募者数 = Application.Count(Columns("B"))
延べ人数 = Application.Sum(Columns("B"))
当選倍率 = Range("B2").Resize(応募者数).Value
当選人数 = Range("C2").Value
ReDim Ladder(1 To 応募者数, 0)
Ladder(1, 0) = 0
Ladder(2, 0) = 当選倍率(1, 1) + 1
For rowNum = 3 To 応募者数
Ladder(rowNum, 0) = Ladder(rowNum - 1, 0) + 当選倍率(rowNum - 1, 1)
Next rowNum
Application.ScreenUpdating = False
Columns("D").ClearContents
IDval = Range("A2:A" & 応募者数 + 1)
Set rngLadder = Range("D2").Resize(応募者数)
rngLadder.Value = Ladder
Set dicT = CreateObject("Scripting.Dictionary")
With Application
Do Until dicT.Count >= 当選人数
該当POS = .RandBetween(1, 延べ人数) '当選番号を算出
dicT(IDval(.Match(該当POS, rngLadder), 1)) = Empty
Loop
End With
Columns("D").ClearContents
Range("D2").Resize(dicT.Count, 1) = Application.Transpose(dicT.Keys)
Range("D1").Value = "当選者"
Application.ScreenUpdating = True
End Sub
（半平太） 2016/12/21(水) 22:49
当選は一人一回として、
Sub test()
Dim c As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim d As Object
Dim e As Object
c = Range("A" & Rows.Count).End(xlUp).Row
Set d = CreateObject("Scripting.Dictionary")
Set e = CreateObject("Scripting.Dictionary")
Range("D2:D" & c).ClearContents
For i = 2 To c
If Cells(i, 2) = "" Then
k = k + 1
d.Add k, Cells(i, 1).Value
Else
For j = 1 To Cells(i, 2).Value
k = k + 1
d.Add k, Cells(i, 1).Value
Next
End If
Next
c = d.Count
k = 2
Randomize
Do
j = Rnd() * c
If Not e.exists(d.Item(j)) Then
e.Add d.Item(j), d.Item(j)
If e.Count <= Range("C2").Value Then
Cells(k, "D").Value = d.Item(j)
k = k + 1
If k > Range("C2").Value + 1 Then Exit Do
Else
Exit Do
End If
End If
Loop
Range("D1").Value = "当選者"
Set d = Nothing
Set e = Nothing
End Sub
とかも、どうでしょうか？
（ウッシ） 2016/12/22(木) 07:40
2順目以降の抽選では既当選者は対象から外すとして、倍率も調整すべきなのでしょうか？
良く分からない・・・
（ウッシ） 2016/12/22(木) 08:11
ウッシさん
こんにちは
＞j = Rnd() * c
Rnd()が「0」を返した時、大丈夫ですか？
倍率は「１倍の人」との比率だと思いますので、 「１倍の人」がずーっと１倍なので、倍率も変わらないと思います。
（半平太） 2016/12/22(木) 09:23
j = Rnd() * c
を
j = Application.RandBetween(1, c)
としないとダメですね。
倍率は、
Cells(k, "D").Value = d.Item(j)
d.Remove j
のように、当選したキーは削除していった方が良いかと思ってましたけど不要なんですね。
（ウッシ） 2016/12/22(木) 09:34
お礼コメントをしたつもりが出来ていませんでした（＞＜）
遅くなりましてすみません。
＞運が10倍いいけど、当選回数は１回ですよね？
＞それとも、運が良ければ、2回でも3回でも当たるんですか？
↑そうです、当選回数は1回です。選ばれる確立が高くなるというだけでした。
曖昧でわかりにくい質問にご丁寧にお答え頂きありがとうございました！
皆様から教えて頂いたマクロで無事に抽選が出来ました
ありがとうございました。
また宜しくお願い致しますm(__)m
（pk） 2017/02/10(金) 11:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.