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

harrisondan2000

如附件，我们需要做一个工单质量检查，在Sheet1的A列中共导出48名同事的282个工单，工单号唯一，我们现在需要随机抽取这48个人每人两个工单到Sheet2进行质量检查，请问如何实现不重复抽取？这个数据只是为了让大神帮忙演示方法，实际数据量要大很多，所以需要使用VBA处理。

harrisondan2000

有没有大神指导一下？万分感谢！

jiminyanyan

题目不错，给你顶一下。。。。。

harrisondan2000

jiminyanyan 发表于 2018-6-7 21:30
题目不错，给你顶一下。。。。。

谢谢~希望有大神可以解答一下~

一把小刀闯天下

'只有47个人

Option Explicit

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

harrisondan2000

一把小刀闯天下 发表于 2018-6-7 22:20
'只有47个人

Option Explicit

嗯嗯，看了一下确实47个人~~谢谢大神！
我还有两个问题：
1. 如果当某一个key(同事)只有一个item(工单), 那么就取不出来两个了，那如何加一个判断，可以使第二次取item时不会出现下标越界的错误呢？
2. 如何将“对应领导”和“工单所在群”的值也返回在新的区域呢？

太强大了！

shi353

Sub test()
  Dim A()
  Set d = CreateObject("scripting.dictionary")
  arr = Sheet1.[A1].CurrentRegion
  For i = 2 To UBound(arr)
    d(arr(i, 1) & "|" & arr(i, 3)) = ""
  Next
  '------------------------------------
  Sheet2.Cells.ClearContents
  brr = d.keys
  Sheet2.[A2].Resize(UBound(brr)) = Application.Transpose(brr)
  crr = Sheet2.[A2].CurrentRegion
  ReDim A(1 To 2, 1 To UBound(crr))
  For i = 1 To UBound(crr)
    AA = Split(crr(i, 1), "|")
    A(1, i) = AA(0): A(2, i) = AA(1)
  Next
  A = Application.Transpose(A)
  '------------------------------------
  With Sheet2
    .Cells.ClearContents
    .[A2].Resize(UBound(A), UBound(A, 2)) = A
    .[A1].Resize(1, 2) = Array(arr(1, 1), arr(1, 3))
  End With
  '------------------------------------
  Sheet2.Activate
  Set DD = Sheet2.[A1].CurrentRegion
  Columns("A:B").AutoFit
  DD.Sort key1:=[A1], key2:=[B1], header:=yes
  '------------------------------------
  Set DD1 = [A1].CurrentRegion.Columns(1)
  DD1.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
End Sub

一把小刀闯天下

harrisondan2000 发表于 2018-6-8 00:22
嗯嗯，看了一下确实47个人~~谢谢大神！
我还有两个问题：
1. 如果当某一个key(同事)只有一个item(工单) ...

Option Explicit

Sub test()
  Dim dic(1), i, t, arr, m, n, s, key
  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
    Else
      dic(0)(arr(i, 1)) = Array(arr(i, 3))
      dic(1)(arr(i, 1)) = Array(arr(i, 2), 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(0): brr(n, 4) = s(1)
    If UBound(t) > 0 Then
      n = n + 1
      brr(n, 1) = key: brr(n, 3) = t(1)
      brr(n, 2) = s(0): brr(n, 4) = s(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 发表于 2018-6-8 00:22
嗯嗯，看了一下确实47个人~~谢谢大神！
我还有两个问题：
1. 如果当某一个key(同事)只有一个item(工单) ...

Option Explicit

Sub test()
  Dim dic(1), i, t, arr, m, n, s, key
  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
    Else
      dic(0)(arr(i, 1)) = Array(arr(i, 3))
      dic(1)(arr(i, 1)) = Array(arr(i, 2), 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(0): brr(n, 4) = s(1)
    If UBound(t) > 0 Then
      n = n + 1
      brr(n, 1) = key: brr(n, 3) = t(1)
      brr(n, 2) = s(0): brr(n, 4) = s(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

shi353 发表于 2018-6-8 06:27
Sub test()
  Dim A()
  Set d = CreateObject("scripting.dictionary")

谢谢谢谢~我回去也试试这种方案~