[已解决]随机数生成,抽签

hbjxgsq

1、单击对应姓名后的单元格，生成随机数，随机整数范围（1-16），然后再C列对应的单元格自动生成奖品。

2、随机数要求，当点击数小于17，无重复数，大于等于17时，生成的随机数最大重复次数最小。玩具

sheet2中是奖品表

请论坛的老师帮助解答，谢谢！ 抽签程序.rar (11.86 KB, 下载次数: 88)

2014-6-12 13:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-6-12 16:58

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Column <> 2 And Target.Row < 3 Or Target.Count > 1 Then Exit Sub
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 3 To UBound(arr)
   
7.         d(arr(i, 1)) = arr(i, 2) & "," & arr(i, 3)
   
8.     Next
   
9.    
   
10.     brr = [a1].CurrentRegion
    
11.     For i = 3 To UBound(brr)
    
12.         If Len(brr(i, 2)) > 0 Then
    
13.             n = n + 1   '记录总抽奖次数
    
14.             d1(brr(i, 2)) = d1(brr(i, 2)) + 1   '记录每种奖品出现次数
    
15.         End If
    
16.     Next
    
17.    
    
18.     Randomize
    
19.     If n < 16 Then   '总次数小于16次，取唯一值
    
20. aa:        R = Int(16 * Rnd) + 1
    
21.         If d1.exists(R) Then GoTo aa
    
22.     Else   '总次数大于16次，取最小值
    
23.         xmin = Application.WorksheetFunction.Min(d1.items)
    
24. bb:        R = Int(16 * Rnd) + 1
    
25.         If d1(R) > xmin Then GoTo bb
    
26.     End If
    
27.     Target = R
    
28.     Target.Offset(0, 1).Resize(1, 2) = Split(d(R), ",")
    
29. End Sub

复制代码

跳转到最佳答案楼层

香川群子

2、随机数要求，当点击数小于17，无重复数，大于等于17时，生成的随机数最大重复次数最小。

你这个要求是多余的。只要满足条件-1就一定满足条件-2

电子表

谢谢！能否帮忙

grf1973

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Column <> 2 And Target.Row < 3 Or Target.Count > 1 Then Exit Sub
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 3 To UBound(arr)
   
7.         d(arr(i, 1)) = arr(i, 2) & "," & arr(i, 3)
   
8.     Next
   
9.    
   
10.     brr = [a1].CurrentRegion
    
11.     For i = 3 To UBound(brr)
    
12.         If Len(brr(i, 2)) > 0 Then
    
13.             n = n + 1   '记录总抽奖次数
    
14.             d1(brr(i, 2)) = d1(brr(i, 2)) + 1   '记录每种奖品出现次数
    
15.         End If
    
16.     Next
    
17.    
    
18.     Randomize
    
19.     If n < 16 Then   '总次数小于16次，取唯一值
    
20. aa:        R = Int(16 * Rnd) + 1
    
21.         If d1.exists(R) Then GoTo aa
    
22.     Else   '总次数大于16次，取最小值
    
23.         xmin = Application.WorksheetFunction.Min(d1.items)
    
24. bb:        R = Int(16 * Rnd) + 1
    
25.         If d1(R) > xmin Then GoTo bb
    
26.     End If
    
27.     Target = R
    
28.     Target.Offset(0, 1).Resize(1, 2) = Split(d(R), ",")
    
29. End Sub

复制代码

grf1973

请看附件。另外第2句改成：
If Target.Column <> 2 Or Target.Row < 3 Or Target.Count > 1 Then Exit Sub

ppp710715

奖品能重复吗？

无止学习

看看是不是你想要的

su45

电子表 发表于 2014-6-12 16:50
谢谢！能否帮忙

电子表，你有几个用户名呀？

ghostjiao

1. Dim n%, brr(1 To 16)
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3.     Dim irow%, arr, i%, iRnd%, temp%, dic1 As Object, dic2 As Object
   
4.     Set dic1 = CreateObject("scripting.dictionary")
   
5.     Set dic2 = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("sheet2").Range("A3:C18")
   
7.     For i = 1 To UBound(arr)
   
8.         dic1(arr(i, 1)) = arr(i, 2)
   
9.         dic2(arr(i, 1)) = arr(i, 3)
   
10.     Next
    
11.     If n = 0 Then
    
12.         For i = 1 To 16
    
13.             brr(i) = i
    
14.         Next
    
15.     End If
    
16.     If Target.Row <= 25 And Target.Row >= 3 And Target.Column = 2 And Target.Cells.Count = 1 And VBA.IsEmpty(Target.Value) Then
    
17.         VBA.Randomize
    
18.         iRnd = Int(Rnd() * (16 - n)) + 1
    
19.         Target.Value = brr(iRnd)
    
20.         Target.Offset(0, 1) = dic1(Target.Value)
    
21.         Target.Offset(0, 2) = dic2(Target.Value)
    
22.         temp = brr(iRnd)
    
23.         brr(iRnd) = brr(16 - n)
    
24.         brr(16 - n) = temp
    
25.         n = n + 1
    
26.         If n = 16 Then n = 0
    
27.     End If
    
28. End Sub
    

复制代码

hbjxgsq

谢谢朋友们的热心解答,获益良多.初学VBA,向你们学习了!