求大神发个抽奖器

lcx8812 · 发表于 2018-7-17 14:10

因为公司从1300号人当中，进行抽奖，每次抽奖50人，共抽六次，抽中的不重复进行抽奖，如果用常规的RAND 加index 的话抽奖会卡顿，所以跪求大神做个抽奖器格式为（部门工号姓名）感激不尽！！！！

Chip_Kenny · 发表于 2018-7-17 14:54

Sub zz()
Dim d As Object, k, n&, s$
Set d = CreateObject("scripting.dictionary")
Do
d(Application.WorksheetFunction.RandBetween(1, 1300)) = ""
Loop Until d.Count = 300
k = d.keys
For i = 1 To 6
s = ""
For j = 0 To 49
s = s & Chr(10) & k(n)
n = n + 1
Next
Debug.Print i & "-" & Mid(s, 2)
Next
End Sub

复制代码

lcx8812 · 发表于 2018-7-17 14:58

Chip_Kenny 发表于 2018-7-17 14:54

大哥能不能帮我做个附件传给我，因为在公司，网络有限制，不能上传附件，感激不尽

Chip_Kenny · 发表于 2018-7-17 15:06

這是思路，由1300個數字先抽出300個, 再分6次,每次抽出50個, 然後debug 列出, 自己運行一次看看，再按實際資料改動一下即可。

lcx8812 · 发表于 2018-7-17 15:42

Chip_Kenny 发表于 2018-7-17 15:06
這是思路，由1300個數字先抽出300個, 再分6次,每次抽出50個, 然後debug 列出, 自己運行一次看看，再按實際 ...

大哥我确实不懂VB，不知道怎么弄，我刚在网上看到个这个http://club.excelhome.net/thread-810313-1-1.html，里面附件里面的抽奖器不错，不过就是需要抽一个点一个，能不能麻烦拜托你帮小弟改动下，改成一次抽取50个，谢谢，我真的点进去看不懂Vb 语言.

一把小刀闯天下 · 发表于 2018-7-17 15:46

'先运行“模拟数据”，然后再抽奖

'循环6次后重新开始

Option Explicit

Dim data, num As Long

Sub 抽奖()
  Dim i, j, k, m, n, t
  If num = 0 Then
data = Range("a2:d" & Cells(Rows.Count, "a").End(xlUp).Row)
Randomize
For i = 1 To UBound(data, 1)
   n = Int(UBound(data, 1) * Rnd) + 1
   For j = 1 To UBound(data, 2)
      t = data(i, j): data(i, j) = data(n, j): data(n, j) = t
   Next
Next
[f:f].Resize(, (UBound(data, 2) + 1) * 6).ClearContents
  End If
  ReDim arr(1 To 50, 1 To UBound(data, 2))
  num = num + 1: n = 0
  For i = 50 * num - 49 To 50 * num
n = n + 1
For j = 1 To UBound(data, 2)
   arr(n, j) = data(i, j)
  Next j, i
  With [f2]
.Offset(, (num - 1) * (UBound(data, 2) + 1)).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  End With
  If num = 6 Then num = 0
End Sub

Sub 模拟数据()
  Dim i
  ReDim arr(1 To 3000, 1 To 4)
  For i = 1 To UBound(arr, 1)
arr(i, 1) = i: arr(i, 3) = 10 ^ 4 + i
arr(i, 2) = "aa": arr(i, 4) = "bb"
  Next
  With [a1]
.Resize(, 4) = Split("序号部门工号姓名")
.Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  End With
End Sub

Chip_Kenny · 发表于 2018-7-17 16:30

Sub zz()
Dim d As Object, k, n&, a(1 To 6, 1 To 51)
Set d = CreateObject("scripting.dictionary")
Do
d(Application.WorksheetFunction.RandBetween(1, 1300)) = ""
Loop Until d.Count = 300
k = d.keys
For i = 1 To 6
a(i, 1) = i & " to " & i * 50
For j = 0 To 49
a(i, j + 2) = k(n)
n = n + 1
Next
Next
[f4].Resize(6, 51) = a
End Sub

复制代码

lcx8812 · 发表于 2018-7-17 16:42

Chip_Kenny 发表于 2018-7-17 16:30

谢谢老师帮助

		自动登录	找回密码
密码			免费注册

[求助] 求大神发个抽奖器