菜鸟求助，评委抽取问题。

志慧树

从102个评委中随机一次抽取7人，每次抽取记录自动保存下来，求大神帮助，感谢！

一把小刀闯天下

Option Explicit

Const NUM = 10 '抽取10次

Sub test()
  Dim arr, i, j, t, n
  arr = [a2:b103]
  ReDim brr(1 To 7, 1 To 2 * NUM)
  Randomize
  For i = 1 To NUM
    For j = 1 To 7
      n = Int(Rnd * (UBound(arr, 1) - j + 1)) + j
      t = arr(i, 1): arr(i, 1) = arr(n, 1): arr(n, 1) = t
      t = arr(i, 2): arr(i, 2) = arr(n, 2): arr(n, 2) = t
      brr(j, 2 * i - 1) = arr(i, 1): brr(j, 2 * i) = arr(i, 2)
  Next j, i
  With [d2]
    .Resize(Rows.Count - 1, UBound(brr, 2) + 1).ClearContents
    .Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
End Sub

719404338

1. Sub t()
   
2. Dim i%, arr, d
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = [b2:b103]
   
5. For j = 3 To 13
   
6. i = 1
   
7. Do
   
8. d(WorksheetFunction.RandBetween(1, 102)) = ""
   
9. If d.Count = 7 Then Exit Do
   
10. Loop
    
11. 
    
12. For Each s In d
    
13. Cells(i, j) = arr(s, 1)
    
14. i = i + 1
    
15. 
    
16. Next
    
17. d.RemoveAll
    
18. Next j
    
19. End Sub
    

复制代码