这个不重复抽奖小程序能用VBA实现吗？

zpy2

http://e.anyoupin.cn/ceshi/jstest/lottery/lottery.php
编号抽奖？

lizhipei78

cjc209 发表于 2023-3-11 12:55

这么简单的代码，收费就不太好了吧

lizhipei78

抽奖.rar (17.45 KB, 下载次数: 16)

2023-3-12 12:59 上传

点击文件名下载附件

给你写好了，麻烦给一朵鲜花，好久没有人送过花了

zyhui1961

cjc209 发表于 2023-3-11 12:54

有时间帮忙看成一下呗，不胜感激！
https://club.excelhome.net/thread-1656313-1-1.html

cjc209

lizhipei78 发表于 2023-3-12 12:59
给你写好了，麻烦给一朵鲜花，好久没有人送过花了

你的是第一轮演讲完后都不知到第3个谁准备了?  不好

佛山小老鼠

我也写了一个，今天闲着着没事

1. Option Explicit
   
2. Sub test()
   
3.     Dim Dic, arr1, L, x, Dic1, L1, arr2, 变, z, arr3, Dic2
   
4.     Set Dic = CreateObject("Scripting.Dictionary")
   
5.     Set Dic1 = CreateObject("Scripting.Dictionary")
   
6.     Set Dic2 = CreateObject("Scripting.Dictionary")
   
7.     '========================================
   
8.     On Error Resume Next
   
9.     L = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
   
10.     arr1 = Sheets(2).Range("A2:A" & L)
    
11.     For x = 1 To UBound(arr1)
    
12.             Dic(arr1(x, 1)) = ""
    
13.    Next x
    
14.   Sheets(2).[A2:A10000].ClearContents
    
15.   Sheets(2).[A2].Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
    
16.    '以上代码是防止重名
    
17.     '================================
    
18.     L1 = Cells(Rows.Count, 4).End(xlUp).Row
    
19.     arr2 = Range("D1:D" & L1).Value
    
20.     For x = 2 To UBound(arr2)
    
21.         Dic1(arr2(x, 1)) = ""
    
22.    Next x
    
23.   L = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
    
24.     arr1 = Sheets(2).Range("A2:A" & L)
    
25.    For x = 1 To UBound(arr1)
    
26.         If Not Dic1.exists(arr1(x, 1)) Then
    
27.             Dic2(arr1(x, 1)) = ""
    
28.         End If
    
29.    Next x
    
30.    arr3 = Dic2.keys
    
31.    For z = 1 To 1800
    
32.         变 = Application.WorksheetFunction.RandBetween(1, Dic2.Count)
    
33.         Cells(2, 2) = arr3(变 - 1)
    
34.     Next z
    
35.     L1 = Cells(Rows.Count, 4).End(xlUp).Row
    
36.          If L1 = L Then MsgBox "全部抽完": End
    
37.     Cells(L1 + 1, 3) = "第" & L1 & "名"
    
38.      Cells(L1 + 1, 4) = Cells(2, 2)
    
39. End Sub
    
40. Sub 重新抽奖()
    
41.     Range("C2:D10000").ClearContents
    
42.     Range("B2:B9").ClearContents
    
43. End Sub

复制代码

lizhipei78

cjc209 发表于 2023-3-12 14:07
你的是第一轮演讲完后都不知到第3个谁准备了?  不好

我干嘛要知道是谁，人家要的是随机，我ARR就是随机的，反正全部抽完就好了。人家本来就没有重复，所以我只是随机调换一下位置，难道不是随机。干嘛要知道下一个是谁

lizhipei78

cjc209 发表于 2023-3-12 14:07
你的是第一轮演讲完后都不知到第3个谁准备了?  不好

难道在你想表达的是这个意思，要每一次上台及预上台的人都有名单么？
那就不要步长2就好了，反正Arr是确定的，就是从头到尾按顺序来就好了
我觉得这个完全符合楼主的意思，第一先随机排序，得到随机数组后，就按顺序来就好了，我觉得没有问题啊

cjc209

lizhipei78 发表于 2023-3-12 15:52
难道在你想表达的是这个意思，要每一次上台及预上台的人都有名单么？
那就不要步长2就好了，反正A ...

你说可以就可以 又不是我要

lizhipei78

抽奖.rar (17.67 KB, 下载次数: 14)

2023-3-12 16:14 上传

点击文件名下载附件

实际生活中应该是这样子的