[已解决]如何产生满足要求的随机数

akb48 · 发表于 2014-5-4 15:35

从sheet2的a3行里随机取2组2个数一组，2组3个数一组，（同一组里的数互不重复）
分别放进sheet1的 b17,c17（一组），b18,c18(一组），b19,c19,d19(一组），b20,c20,d20（一组）
要求必不与sheet2 a2 行里的数
a2和a3行单元格的个数不一定

最佳答案

月排行榜 / 总排行榜

grf1973

2014-5-5 09:16

怎么代码格式没了？

Sub 随机()
Dim xrng As Range
Dim datarange As Integer
Dim brr(1 To 4, 1 To 3)
Dim rng As Integer
With Sheet2
Set xrng = .Range(.[a2], .[a2].End(xlToRight)) '不参与随机的数字
arr = .Range(.[a3], .[a3].End(xlToRight)) '所有数字
ReDim crr(1 To UBound(arr, 2)) '所有数字中去掉不参与随机的数字
For i = 1 To UBound(arr, 2)
If Application.WorksheetFunction.CountIf(xrng, arr(1, i)) = 0 Then '去掉不参与随机的数字
n = n + 1
crr(n) = arr(1, i)
End If
Next
End With
For k = 1 To 4
drr = crr
p = n
q = IIf(k <= 2, 2, 3)
For i = 1 To q
rng = Int((p * Rnd) + 1)
brr(k, i) = drr(rng)
drr(rng) = drr(p)
p = p - 1
Next
Next
Sheet1.Range("b15").Resize(4, 3) = brr
End Sub

复制代码

跳转到最佳答案楼层

grf1973 · 发表于 2014-5-4 16:10

Sub 随机()
Dim datarange As Integer
Dim brr(1 To 4, 1 To 3)
Dim rng As Integer
datarange = Sheet2.Range("a3").End(xlToRight).Column
For k = 1 To 4
arr = Sheet2.Range("a3").Resize(1, datarange)
p = datarange
q = IIf(k <= 2, 2, 3)
For i = 1 To q
rng = Int((p * Rnd) + 1)
brr(k, i) = arr(1, rng)
arr(1, rng) = arr(1, p)
p = p - 1
Next
Next
Sheet1.Range("b15").Resize(4, 3) = brr
End Sub

复制代码

grf1973 · 发表于 2014-5-4 16:12

是不是这样？“要求必不与sheet2 a2 行里的数
a2和a3行单元格的个数不一定”这句话看不懂

akb48 · 发表于 2014-5-4 16:53

本帖最后由 akb48 于 2014-5-4 19:50 编辑

grf1973 发表于 2014-5-4 16:12
是不是这样？“要求必不与sheet2 a2 行里的数
a2和a3行单元格的个数不一定”这句话看不懂

必不与sheet2 a2 行里的数相同，
少打了两个字，
sheet2 a2这行出现的数字不参与随机
如a2=A3,b2=A5,则实际参与随机的数是A1,A2,A4,A6

grf1973 · 发表于 2014-5-5 09:14

akb48 发表于 2014-5-4 16:53
必不与sheet2 a2 行里的数相同，
少打了两个字，
sheet2 a2这行出现的数字不参与随机

把初始的数组去掉不参与随机的数字即可。见代码

Sub 随机()
Dim xrng As Range
Dim datarange As Integer
Dim brr(1 To 4, 1 To 3)
Dim rng As Integer
With Sheet2
Set xrng = .Range(.[a2], .[a2].End(xlToRight)) '不参与随机的数字
arr = .Range(.[a3], .[a3].End(xlToRight)) '所有数字
ReDim crr(1 To UBound(arr, 2)) '所有数字中去掉不参与随机的数字
For i = 1 To UBound(arr, 2)
If Application.WorksheetFunction.CountIf(xrng, arr(1, i)) = 0 Then '去掉不参与随机的数字
n = n + 1
crr(n) = arr(1, i)
End If
Next
End With
For k = 1 To 4
drr = crr
p = n
q = IIf(k <= 2, 2, 3)
For i = 1 To q
rng = Int((p * Rnd) + 1)
brr(k, i) = drr(rng)
drr(rng) = drr(p)
p = p - 1
Next
Next
Sheet1.Range("b15").Resize(4, 3) = brr
End Sub

复制代码

grf1973 · 发表于 2014-5-5 09:16

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

怎么代码格式没了？

Sub 随机()
Dim xrng As Range
Dim datarange As Integer
Dim brr(1 To 4, 1 To 3)
Dim rng As Integer
With Sheet2
Set xrng = .Range(.[a2], .[a2].End(xlToRight)) '不参与随机的数字
arr = .Range(.[a3], .[a3].End(xlToRight)) '所有数字
ReDim crr(1 To UBound(arr, 2)) '所有数字中去掉不参与随机的数字
For i = 1 To UBound(arr, 2)
If Application.WorksheetFunction.CountIf(xrng, arr(1, i)) = 0 Then '去掉不参与随机的数字
n = n + 1
crr(n) = arr(1, i)
End If
Next
End With
For k = 1 To 4
drr = crr
p = n
q = IIf(k <= 2, 2, 3)
For i = 1 To q
rng = Int((p * Rnd) + 1)
brr(k, i) = drr(rng)
drr(rng) = drr(p)
p = p - 1
Next
Next
Sheet1.Range("b15").Resize(4, 3) = brr
End Sub

复制代码

grf1973 · 发表于 2014-5-5 09:17

请看附件。

akb48 · 发表于 2014-5-5 11:25

grf1973 发表于 2014-5-5 09:17
请看附件。

如果A3行最后几格是这种有数组公式，但却是空白的单元格，如G3,H3,I3,J3，用 datarange = Sheets("参数").Range("a15").End(xlToRight).Column，都会提到到这几个单元格。导致随机出来的数会出现空白，怎么能够解决这个问题
QQ图片20140505111933.jpg

grf1973 · 发表于 2014-5-5 11:31

If Application.WorksheetFunction.CountIf(xrng, arr(1, i)) = 0 And Len(arr(1,i))>0 Then

akb48 · 发表于 2014-5-5 13:22

grf1973 发表于 2014-5-5 11:31
If Application.WorksheetFunction.CountIf(xrng, arr(1, i)) = 0 And Len(arr(1,i))>0 Then

Sub 随机()
Dim datarange As Integer
Dim brr(1 To 4, 1 To 3)
Dim rng As Integer
datarange = Sheet2.Range("a3").End(xlToRight).Column
For k = 1 To 4
arr = Sheet2.Range("a3").Resize(1, datarange)
p = datarange
q = IIf(k <= 2, 2, 3)
For i = 1 To q
rng = Int((p * Rnd) + 1)
brr(k, i) = arr(1, rng)
arr(1, rng) = arr(1, p)
p = p - 1
Next
Next
Sheet1.Range("b15").Resize(4, 3) = brr
End sub

a2行不出的数字我用公式去掉了。

如果是原来这段代码要加在哪？

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