抽奖系统指定名单中奖

355270054

点击抽奖后，就会按准备好的“人员名单列表”在D2单元格滚动名单的（在下面已中奖的名单不会出现在滚动这里），然后点击中奖，就会停止滚动，顺便把该单元格的名字，填到下面的框框上，都是按顺序填入的。
现在我想要实现一个效果就是，在“人员名单列表”那里，该名单在A列，只要我在B列对应的格子，填上个空格，该名单就会中特等奖，但是，在前面的一二三四等奖就不会出现这个名字的。因为整个抽奖过程的名字是不可以重复中奖的。

求大神帮忙。谢谢。

chxw68

呵呵，怪不得现在人们对中奖的兴趣不大了。

micch

都内定了还搞这么复杂干嘛

小花鹿

造假                                                                                                                           

源理

路过看戏

xmtt

彩票摇奖也同样思路吗

355270054

chxw68 发表于 2020-1-17 21:36
呵呵，怪不得现在人们对中奖的兴趣不大了。

哎，我也是没办法，领导要求我弄，必须让某个经理中奖。

chxw68

355270054 发表于 2020-1-18 00:07
哎，我也是没办法，领导要求我弄，必须让某个经理中奖。

特等奖有几个人？

chxw68

1. Private Sub cmd_1_Click()
   
2.   Dim r%, i%
   
3.   Static arr, brr
   
4.   Static x%, y%
   
5.   Dim crr, drr
   
6.   Dim d As Object
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   If cmd_1.Caption = "开始" Then
   
10.     cmd_1.Caption = "停止"
    
11.   Else
    
12.     cmd_1.Caption = "开始"
    
13.   End If
    
14.   If cmd_1.Caption = "停止" Then
    
15.     flg = True
    
16.     With Worksheets("人员名单列表")
    
17.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.       brr = .Range("a1:b" & r)
    
19.       For i = 1 To UBound(brr)
    
20.         d(brr(i, 1)) = ""
    
21.         If Len(brr(i, 2)) <> 0 Then
    
22.           d1(brr(i, 1)) = ""
    
23.         End If
    
24.       Next
    
25.     End With
    
26.     With Worksheets("sheet1")
    
27.       arr = .Range("b4:f26")
    
28.       For i = 1 To UBound(arr)
    
29.         For j = 1 To UBound(arr, 2)
    
30.           If Len(arr(i, j)) <> 0 Then
    
31.             If d.exists(arr(i, j)) Then
    
32.               d.Remove (arr(i, j))
    
33.             End If
    
34.           End If
    
35.         Next
    
36.       Next
    
37.       For i = UBound(arr) To 1 Step -1
    
38.         For j = UBound(arr, 2) To 1 Step -1
    
39.           If Len(arr(i, j)) = 0 Then
    
40.             x = i
    
41.             y = j
    
42.           End If
    
43.         Next
    
44.       Next
    
45.       i = 23
    
46.       For j = 1 To UBound(arr, 2)
    
47.         If Len(arr(i, j)) <> 0 Then
    
48.           If d1.exists(arr(i, j)) Then
    
49.             d1.Remove (arr(i, j))
    
50.           End If
    
51.         End If
    
52.       Next
    
53.     End With
    
54.     crr = d.keys
    
55.     drr = d1.keys
    
56.     Do While flg
    
57.       DoEvents
    
58.       m = Int(Rnd() * (UBound(crr) + 1))
    
59.       If x < 23 Then
    
60.         If Not d1.exists(crr(m)) Then
    
61.           Worksheets("sheet1").Range("d2") = crr(m)
    
62.         End If
    
63.       Else
    
64.         If d1.Count > 0 Then
    
65.           m = Int(Rnd() * (UBound(drr) + 1))
    
66.           Worksheets("sheet1").Range("d2") = drr(m)
    
67.         Else
    
68.           Worksheets("sheet1").Range("d2") = crr(m)
    
69.         End If
    
70.       End If
    
71.     Loop
    
72.   Else
    
73.     flg = False
    
74.     Worksheets("sheet1").Cells(x + 3, y + 1) = Worksheets("sheet1").Range("d2")
    
75.   End If
    
76. End Sub
    

复制代码

chxw68

当做练习题练练手。