[已解决]用VBA随机部姓名问题

laoau138

用VBA随机部姓名问题

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-29 21:43

随机值排序比较麻烦，以下代码为未排序的。
必需的话在代码最后加入一句工作表排序就行了。

1. Sub aaa()
   
2. Dim arr, brr, crr, i&, j&, d As Object, c, n&, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a2:d" & [a65536].End(3).Row)
   
5. For i = 1 To UBound(arr)
   
6.   d(arr(i, 2) & "," & arr(i, 4)) = d(arr(i, 2) & "," & arr(i, 4)) & "," & i
   
7. Next i
   
8. ReDim crr(1 To d.Count, 1 To 4)
   
9. Randomize
   
10. For Each c In d.keys
    
11.   brr = Split(d(c), ",")
    
12.   r = r + 1
    
13.   n = Int(UBound(brr) * Rnd + 1)
    
14.   For j = 1 To 4
    
15.     crr(r, j) = arr(brr(n), j)
    
16.   Next j
    
17. Next c
    
18. [f2].Resize(r, 4) = crr
    
19. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

随机值排序比较麻烦，以下代码为未排序的。
必需的话在代码最后加入一句工作表排序就行了。

1. Sub aaa()
   
2. Dim arr, brr, crr, i&, j&, d As Object, c, n&, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a2:d" & [a65536].End(3).Row)
   
5. For i = 1 To UBound(arr)
   
6.   d(arr(i, 2) & "," & arr(i, 4)) = d(arr(i, 2) & "," & arr(i, 4)) & "," & i
   
7. Next i
   
8. ReDim crr(1 To d.Count, 1 To 4)
   
9. Randomize
   
10. For Each c In d.keys
    
11.   brr = Split(d(c), ",")
    
12.   r = r + 1
    
13.   n = Int(UBound(brr) * Rnd + 1)
    
14.   For j = 1 To 4
    
15.     crr(r, j) = arr(brr(n), j)
    
16.   Next j
    
17. Next c
    
18. [f2].Resize(r, 4) = crr
    
19. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-4-29 21:43
随机值排序比较麻烦，以下代码为未排序的。
必需的话在代码最后加入一句工作表排序就行了。

Sub suij()
    Dim d As Object, arr, brr, i&, j&, k&
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    ReDim brr(1 To 10, 1 To 4)
    Do While k < 10
        temp = Application.RandBetween(2, UBound(arr))
        bmxb = arr(temp, 2) & arr(temp, 4)
        If Not d.exists(temp) Then
            If Not d.exists(bmxb) Then
                d(bmxb) = ""
                d(temp) = ""
                k = k + 1
                For j = 1 To 4
                    brr(k, j) = arr(temp, j)
                Next
            End If
        End If
    Loop
    [f2].Resize(10, 4) = brr
    Set d = Nothing
    MsgBox "ok"
End Sub

大灰狼1976

我的思路跟你贴的代码是完全不一样的。
我是先将同部门同性别的行号都记录进字典，
再遍历字典的KEY，在每个ITEM里面取一个随机值就可以了，不会存在重复，
所以可以用FOR循环来做，也可以在初期就确定结果数组的最大下标。
你贴的代码是先在数组中选随机行号，再来判断取到的数据是否跟已有数据冲突，
如果没有就新增，如有就跳过，由于有这种不确定性，所以必须用DO LOOP循环来做。

当然，结果跟我的一样是没有排序的，这本来就不是什么问题。

大灰狼1976

你贴的代码还有一个问题，它是在知道K＝10，也就是说已知有10条结果记录的前提下，用WHILE K<10做为跳出DO LOOP循环的条件，如果事先不知道的话，它是无法得出正确结果的（甚至陷入死循环），不信你可以通过增减你的原始数据来验证。

laoau138

大灰狼1976 发表于 2017-4-29 23:15
你贴的代码还有一个问题，它是在知道K＝10，也就是说已知有10条结果记录的前提下，用WHILE K

这个对不对

大灰狼1976

K，X变量都给定值了，还有什么好看的。
你随便弄些数据验证下就明白了。