他山之石——VBA随机抽取

随机抽取的业务意义是什么？似乎在临床试验的随机化中可以用到。先mark一下，需要时再来。

Sub 随机挑选演示程序1()
  Dim arr
  Dim x As Integer, num As Integer, k As Integer
  Range("c1:c10") = ""
  Range("a1:a10") = Application.Transpose(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
  For x = 1 To 10
     num = (Rnd() * (10 - 1) + 1) \ 1
     Range("a1:a10").Interior.ColorIndex = xlNone
     Range("a" & num).Interior.ColorIndex = 6
     Range("c" & x) = Range("a" & num)
  Next x
End Sub
Sub 移形换位演示程序()
  Dim arr
  Dim x As Integer, num As Integer, k As Integer, sr As String
  Range("c1:c10") = ""
  Range("a1:a10") = Application.Transpose(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
  For x = 1 To 10
     num = (Rnd() * ((10 - x + 1) - 1) + 1) \ 1
     Range("a1:a" & (10 - x + 1)).Interior.ColorIndex = xlNone
     Range("a" & num).Interior.ColorIndex = 6
     Range("c" & x) = Range("a" & num)
     '下面开始换位
      sr = Range("a" & num)
      Range("a" & num) = Range("a" & (10 - x + 1))
      Range("a" & (10 - x + 1)) = sr
      Range("a" & (10 - x + 1)).Interior.ColorIndex = 1
  Next x
End Sub

 

Sub 随机抽取字典法()
 Dim d As Object
 Dim arr, num As Integer, x As Integer, arr1(1 To 20000, 1 To 1) As String, t
 t = Timer
 Set d = CreateObject("scripting.dictionary")
 arr = Range("a1:a20000")
 For x = 1 To 20000
100:
   num = Rnd() * (20000 - 1) + 1
   If d.exists(num) Then
     GoTo 100
   Else
     d(num) = ""
     arr1(x, 1) = arr(num, 1)
   End If
 Next x
    Range("c1:c20000") = ""
    Range("c1:c20000") = arr1
   [d65536].End(xlUp).Offset(1, 0) = Timer - t
End Sub

'提速依据
   '在换位时数字的换位速度要比文本型要快。所以借力数值型数组达到提速的目的
Sub 移形随机排序()
   Dim arr
   Dim arr1(1 To 20000, 1 To 1) As String, sr As String
   Dim x As Integer, num, t
   t = Timer
   arr = Range("a1:a20000")
   For x = 1 To UBound(arr)
      num = (Rnd() * ((20000 - x + 1) - 1) + 1) \ 1
      arr1(x, 1) = arr(num, 1)
      '换位
      sr = arr(num, 1)
      arr(num, 1) = arr(20000 - x + 1, 1)
      arr(20000 - x + 1, 1) = sr
   Next x
   Range("c1:c20000") = ""
   Range("c1:c20000") = arr1
   [d65536].End(xlUp).Offset(1, 0) = Timer - t
End Sub
Sub 移形随机排序升级()
   Dim arr
   Dim arr1(1 To 20000, 1 To 1) As String, sr As Integer
   Dim x As Integer, num, t, y
   Dim arr2(1 To 20000)
   t = Timer
   arr = Range("a1:a20000")
   For y = 1 To 20000
     arr2(y) = y
   Next y
   For x = 1 To UBound(arr)
      num = (Rnd() * ((20000 - x + 1) - 1) + 1) \ 1
      arr1(x, 1) = arr(arr2(num), 1)
      '换位
      sr = arr2(num)
      arr2(num) = arr2(20000 - x + 1)
      arr2(20000 - x + 1) = num
   Next x
   Range("c1:c20000") = ""
   Range("c1:c20000") = arr1
    [F65536].End(xlUp).Offset(1, 0) = Timer - t
End Sub