[已解决]求助大神，用vba实现新生招生报名摇号！

yangxibing

求助大神，用vba实现新生招生报名摇号！根据学校学校位数，为新生随机安排学校，叩谢大神。
qq:624910936
微信：Y624910936

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-7-25 19:21

yangxibing 发表于 2021-7-25 18:46
新想法：点击开始摇号时，屏幕连续变化（不间断），点击停止摇号，屏幕停止，为最终确定数据。

Dim gstop
Sub demo()
   Randomize
   a = Sheet3.UsedRange
   cnt = a(UBound(a), 2)
   ReDim s(1 To cnt), n(1 To cnt)
   For i = 2 To UBound(a) - 1
      For j = 1 To a(i, 2)
         c = c + 1: s(c) = a(i, 1): n(c) = c
      Next
   Next
   Sheet6.[a2:g1000].ClearContents
   b = Sheet4.Range("a2:g" & Sheet4.[a2].End(4).Row)
   cnt = Application.Min(cnt, UBound(b))
   gstop = 0
   Do While gstop = 0
      For i = 1 To cnt
         k = i + Int(Rnd * (cnt - i + 1))
         tmp = s(i): s(i) = s(k): s(k) = tmp
         tmp = n(i): n(i) = n(k): n(k) = tmp
         b(i, 6) = s(i): b(i, 7) = n(i)
      Next
      Sheet6.[a2].Resize(cnt, 7) = b
      DoEvents
   Loop
End Sub
Sub mystop()
   gstop = 1
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

wanao2008

我看到学校的学位数有279个，而“摇号结果”表里的学生有304个，
所以我就设计成了双随机数。
但愿能帮到你：

Sub byWanao()
    Dim arr, brr, i%, j%, k%, endNum%, sNum%, pNum%
    Randomize
    Sheet6.Range("F2:F600").ClearContents   '先清空数据
    arr = Sheet3.UsedRange
    brr = Sheet6.UsedRange
    sNum = UBound(arr) - 2      '取学校总数
    pNum = UBound(brr) - 1      '取学生总数
    endNum = arr(UBound(arr), 2)
    If endNum > UBound(brr) Then endNum = UBound(brr)
    For i = 2 To endNum + 1
        Do
            j = Int(Rnd * sNum) + 1     '随机取一个学校
            If arr(j + 1, 2) <> 0 Then Exit Do
        Loop
        arr(j + 1, 2) = arr(j + 1, 2) - 1
        Do
            k = Int(Rnd * pNum) + 1     '随机取一个学生
            If brr(k + 1, 6) = "" Then Exit Do
        Loop
        brr(k + 1, 6) = arr(j + 1, 1)   '把学校赋值给学生
    Next
    Sheet6.Range("A1").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

yangxibing

wanao2008 发表于 2021-7-24 20:40
我看到学校的学位数有279个，而“摇号结果”表里的学生有304个，
所以我就设计成了双随机数。
但愿能帮到 ...

感谢您，已完美解决，我又增加了随机序号，现将附件上传，供有需要的下载。谢谢您！

hws

向大神学习！

cutecpu

Sub demo()
   Randomize
   a = Sheet3.UsedRange
   cnt = a(UBound(a), 2)
   ReDim s(1 To cnt), n(1 To cnt)
   For i = 2 To UBound(a) - 1
      For j = 1 To a(i, 2)
         c = c + 1: s(c) = a(i, 1): n(c) = c
      Next
   Next
   b = Sheet4.Range("a2:g" & Sheet4.[a2].End(4).Row)
   cnt = Application.Min(cnt, UBound(b))
   For i = 1 To cnt
      k = i + Int(Rnd * (cnt - i + 1))
      tmp = s(i): s(i) = s(k): s(k) = tmp
      tmp = n(i): n(i) = n(k): n(k) = tmp
      b(i, 6) = s(i): b(i, 7) = n(i)
   Next
   Sheet6.[a2:g1000].ClearContents
   Sheet6.[a2].Resize(cnt, 7) = b
End Sub

祝順心，南無阿彌陀佛！

yangxibing

新想法：点击开始摇号时，屏幕连续变化（不间断），点击停止摇号，屏幕停止，为最终确定数据。

cutecpu

yangxibing 发表于 2021-7-25 18:46
新想法：点击开始摇号时，屏幕连续变化（不间断），点击停止摇号，屏幕停止，为最终确定数据。

Dim gstop
Sub demo()
   Randomize
   a = Sheet3.UsedRange
   cnt = a(UBound(a), 2)
   ReDim s(1 To cnt), n(1 To cnt)
   For i = 2 To UBound(a) - 1
      For j = 1 To a(i, 2)
         c = c + 1: s(c) = a(i, 1): n(c) = c
      Next
   Next
   Sheet6.[a2:g1000].ClearContents
   b = Sheet4.Range("a2:g" & Sheet4.[a2].End(4).Row)
   cnt = Application.Min(cnt, UBound(b))
   gstop = 0
   Do While gstop = 0
      For i = 1 To cnt
         k = i + Int(Rnd * (cnt - i + 1))
         tmp = s(i): s(i) = s(k): s(k) = tmp
         tmp = n(i): n(i) = n(k): n(k) = tmp
         b(i, 6) = s(i): b(i, 7) = n(i)
      Next
      Sheet6.[a2].Resize(cnt, 7) = b
      DoEvents
   Loop
End Sub
Sub mystop()
   gstop = 1
End Sub

祝順心，南無阿彌陀佛！

yangxibing

cutecpu 发表于 2021-7-25 19:21
Dim gstop
Sub demo()
   Randomize

谢谢谢谢！太感谢了！

yangxibing

还想麻烦您看看，能不能在左边的册子里，实现右边这样的效果。摇号时所有的信息都滚动，排除家长认为随机安排的学校是摇号人员提前安排好的（有的家长会有这种想法）。
能实现右边这样的效果的话，随机序号这一列就可以取了。
当时加随机序号这一列的想法是，随机序号后，对参加摇号的学生重新排序（主要目的是打乱顺序），再随机配位学校。

cutecpu

yangxibing 发表于 2021-7-25 21:09
还想麻烦您看看，能不能在左边的册子里，实现右边这样的效果。摇号时所有的信息都滚动，排除家长认为随机安 ...

Dim gstop
Sub demo()
   Randomize
   a = Sheet3.UsedRange
   cnt = a(UBound(a), 2)
   ReDim s(1 To cnt), n(1 To cnt)
   For i = 2 To UBound(a) - 1
      For j = 1 To a(i, 2)
         c = c + 1: s(c) = a(i, 1): n(c) = c
      Next
   Next
   Sheet6.[a2:g1000].ClearContents
   b = Sheet4.Range("a2:g" & Sheet4.[a2].End(4).Row)
   cnt = Application.Min(cnt, UBound(b))
   ReDim bb(1 To cnt, 1 To 7)
   gstop = 0
   Do While gstop = 0
      For i = 1 To cnt
         k = i + Int(Rnd * (cnt - i + 1))
         kk = i + Int(Rnd * (cnt - i + 1))
         tmp = s(i): s(i) = s(k): s(k) = tmp
         tmp = n(i): n(i) = n(kk): n(kk) = tmp
         bb(i, 6) = s(i): bb(i, 7) = n(i)
         For j = 1 To 5
            bb(i, j) = b(n(i), j)
         Next
      Next
      Sheet6.[a2].Resize(cnt, 7) = bb
      DoEvents
   Loop
End Sub
Sub mystop()
   gstop = 1
End Sub

祝順心，南無阿彌陀佛！