请问如何实现不重复抽取？

harrisondan2000

一把小刀闯天下 发表于 2018-6-8 07:04
Option Explicit

Sub test()

嗯嗯，完美解决问题!~谢谢谢谢！

darlingxx

太强大了，好好学习

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, crr()
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.       m = 1
    
13.       ReDim brr(1 To UBound(arr, 2), 1 To m)
    
14.     Else
    
15.       brr = d(arr(i, 1))
    
16.       m = UBound(brr, 2) + 1
    
17.       ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
18.     End If
    
19.     For j = 1 To UBound(arr, 2)
    
20.       brr(j, m) = arr(i, j)
    
21.     Next
    
22.     d(arr(i, 1)) = brr
    
23.   Next
    
24.   ReDim drr(1 To d.Count * 2, 1 To 4)
    
25.   m = 0
    
26.   For Each aa In d.keys
    
27.     arr = d(aa)
    
28.     ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
29.     For i = 1 To UBound(arr)
    
30.       For j = 1 To UBound(arr, 2)
    
31.         brr(j, i) = arr(i, j)
    
32.       Next
    
33.     Next
    
34.     ReDim crr(1 To UBound(brr))
    
35.     For i = 1 To UBound(brr)
    
36.       crr(i) = i
    
37.     Next
    
38.     For i = 1 To Application.Min(UBound(crr), 2)
    
39.       n = Int(Rnd() * (UBound(crr) - i)) + i + 1
    
40.       temp = crr(i)
    
41.       crr(i) = crr(n)
    
42.       crr(n) = temp
    
43.       m = m + 1
    
44.       For j = 1 To UBound(brr, 2)
    
45.         drr(m, j) = brr(crr(i), j)
    
46.       Next
    
47.     Next
    
48.   Next
    
49.   With Worksheets("sheet2")
    
50.     .Range("a2").Resize(m, UBound(drr, 2)) = drr
    
51.   End With
    
52.   
    
53. End Sub
    

复制代码

chxw68

凑个热闹。

harrisondan2000

chxw68 发表于 2018-6-8 09:28
凑个热闹。

谢谢，我要好好学习一下这个思路~

386026398

采用不重复的随机函数

harrisondan2000

一把小刀闯天下 发表于 2018-6-8 07:04
Option Explicit

Sub test()

您好，这个代码非常好用，但我在使用的过程中还有发现了一个问题：每次随机抽取出来的值，工单号，姓名，领导是对应的，但工单号所对应的工单群号不对，我自己尝试了去设置断点找出原因，可是找不出来，您能再指导一下吗？~~

一把小刀闯天下

harrisondan2000 发表于 2018-6-24 19:01
您好，这个代码非常好用，但我在使用的过程中还有发现了一个问题：每次随机抽取出来的值，工单号，姓名， ...

'看了一下相同姓名的所在"工单所在群"可以不同，很难理解，原来代码没有考虑这种可能

'一般来说相同姓名"对应领导"、"工单所在群"应该一样的,唯一可以不同的是"工单"，但是事实并不是这样

'换种方法给你重写了一遍，自己测试一下

Option Explicit

Sub test()
  Dim arr, t, i, j, k, kk, n, m
  arr = Range("a2:d" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2))
  t = arr: Call msort(arr, t, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) <> arr(j + 1, 1) Then
        If j - i + 1 <= 2 Then '同名<=2人直接获取
          For k = i To j
            n = n + 1
            For kk = 1 To UBound(arr, 2): brr(n, kk) = arr(k, kk): Next
          Next
        Else
          Randomize
          For k = i To i + 1 '同名>2人随机取同名中的2人
            n = n + 1: m = Int(Rnd * (j - k + 1)) + k
            For kk = 1 To UBound(arr, 2)
              t = arr(k, kk): arr(k, kk) = arr(m, kk): arr(m, kk) = t
            Next
            For kk = 1 To UBound(arr, 2): brr(n, kk) = arr(k, kk): Next
          Next
        End If
        i = j: Exit For
      End If
  Next j, i
  With [f2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

Function msort(arr, temp, first, last, left, right, key)
  Dim i, j, k, kk, mid
  If first <> last Then
    mid = Int((first + last) / 2)
    msort arr, temp, first, mid, left, right, key
    msort arr, temp, mid + 1, last, left, right, key
    i = first: j = mid + 1: k = first
    While i <= mid And j <= last
      If arr(i, key) <= arr(j, key) Then
        For kk = left To right: temp(k, kk) = arr(i, kk): Next
        k = k + 1: i = i + 1
      Else
        For kk = left To right: temp(k, kk) = arr(j, kk): Next
        k = k + 1: j = j + 1
      End If
    Wend
    While i <= mid
      For kk = left To right: temp(k, kk) = arr(i, kk): Next
      k = k + 1: i = i + 1
    Wend
    While j <= last
      For kk = left To right: temp(k, kk) = arr(j, kk): Next
      k = k + 1: j = j + 1
    Wend
    For i = first To last
      For j = left To right
        arr(i, j) = temp(i, j)
    Next j, i
  End If
End Function

jiminyanyan

harrisondan2000 发表于 2018-6-24 19:01
您好，这个代码非常好用，但我在使用的过程中还有发现了一个问题：每次随机抽取出来的值，工单号，姓名， ...

Option Explicit

Sub jimin()
  Dim dic(2), i, t, arr, m, n, s, key, kk
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If dic(0).exists(arr(i, 1)) Then
      t = dic(0)(arr(i, 1))
      ReDim Preserve t(UBound(t) + 1)
      t(UBound(t)) = arr(i, 3)
      dic(0)(arr(i, 1)) = t
      dic(2)(arr(i, 3)) = arr(i, 4)
    Else
      dic(0)(arr(i, 1)) = Array(arr(i, 3))
      dic(1)(arr(i, 1)) = arr(i, 2)
      dic(2)(arr(i, 3)) = arr(i, 4)
    End If
  Next
  ReDim brr(1 To dic(0).Count * 2, 1 To 4) As String
  Randomize
  For Each key In dic(0).keys
    t = dic(0)(key)
    For i = 0 To UBound(t)
      m = Int(Rnd * (UBound(t) + 1))
      s = t(i): t(i) = t(m): t(m) = s
    Next
    s = dic(1)(key)
    n = n + 1
    brr(n, 1) = key: brr(n, 3) = t(0)
    brr(n, 2) = s: brr(n, 4) = dic(2)(t(0))
    If UBound(t) > 0 Then
      n = n + 1
      brr(n, 1) = key: brr(n, 3) = t(1)
      brr(n, 2) = s: brr(n, 4) = dic(2)(t(1))
    End If
  Next
  With [f2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(Rows.Count - 1, UBound(brr, 2)).NumberFormatLocal = "@"
    .Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  End With
End Sub

harrisondan2000

好的好的，谢谢，我测试一下~