不重复随机提取数据

张雄友

提取数据。

cqlpjxx

'看看我的思路

Sub 随机抽取()
Dim arr, brr, d, i, m, n
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Select
arr = [A2:E26]
brr = [H1:k5]
For i = 1 To 1000
If arr((Rnd() * 100 Mod 25) + 1, (Rnd() * 100 Mod 5) + 1) <> "" And arr((Rnd() * 100 Mod 25) + 1, (Rnd() * 100 Mod 5) + 1) <> "停产" Then
d(arr((Rnd() * 100 Mod 25) + 1, (Rnd() * 100 Mod 5) + 1)) = ""
If d.Count = 17 Then Exit For                    '提取17个不同的数后，退出循环
End If
Next
arr = d.keys
m = 1: n = 0
For i = 0 To 16
n = n + 1
brr(m, n) = arr(i)            '将17个数写入数组
If n = 4 Then
n = 0
m = m + 1
End If
Next
[H1:k5] = brr                 '将数组写入单元格

End Sub

cqlpjxx

修改一下代码

Sub 随机抽取()
Dim arr, brr, d, i, m, n, ro, co
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Select
arr = [A2:E26]
brr = [H1:k5]
For i = 1 To 1000
ro = (Rnd() * 100 Mod 25) + 1: co = (Rnd() * 100 Mod 5) + 1
If arr(ro, co) <> "" And arr(ro, co) <> "停产" Then d(arr(ro, co)) = ""
If d.Count = 17 Then Exit For                    '提取17个不同的数后，退出循环
Next
arr = d.keys
m = 1: n = 0
For i = 0 To 16
n = n + 1
brr(m, n) = arr(i)            '将17个数写入数组
If n = 4 Then
n = 0
m = m + 1
End If
Next
[H1:k5] = brr                 '将数组写入单元格

End Sub

cqlpjxx

请测试.....................

huang1314wei

1. Sub text()
   
2.     Dim arr, i%, j%, n%, m%, x%, brr(), d
   
3.     arr = Range("A2:E26")
   
4.     ReDim brr(1 To 17)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For n = 1 To 17
   
7. 100:  i = Int(Rnd * UBound(arr)) + 1
   
8.       j = Int(Rnd * UBound(arr, 2)) + 1
   
9.       If arr(i, j) <> "" And arr(i, j) <> "停产" Then
   
10.         If Not d.exists(arr(i, j)) Then
    
11.             brr(n) = arr(i, j)
    
12.             d(arr(i, j)) = ""
    
13.         Else
    
14.             GoTo 100
    
15.         End If
    
16.       End If
    
17.     Next
    
18.     Range("H2:K6").ClearContents
    
19.     For i = 2 To 6
    
20.         For m = 8 To 11
    
21.             x = x + 1
    
22.             Cells(i, m) = brr(x)
    
23.             If x = 17 Then Exit Sub
    
24.         Next
    
25.     Next
    
26. End Sub

复制代码

hhjjpp

逃离代码的随意：

张雄友

hhjjpp 发表于 2015-9-26 16:00
逃离代码的随意：

看过你很多贴子是位函数高手！