已有抽签程序，修改每个单位限制为一人

nusitxue

大家好，因为要做一个随机抽签考试的程序，从咱们论坛上下载一个抽签附件，原来的代码中为每个单位限制为最多2人，能否修改成最多1人？


原代码如下：
ion Explicit

Sub zz()
Dim d, a As Collection, rng As Range
Dim i&, j&, k&, l%, n&, m&, x, y&, z&, s$
Set d = CreateObject("Scripting.Dictionary")
m = 2 ''标题行(行数)
y = [B65536].End(3).Row - m
For i = 1 To y
   d(Cells(i + m, 2).Value) = ""
Next
k = d.Count
l = k * 2 - 1
d.RemoveAll
[d3:f22].ClearContents
x = InputBox("请输入需抽取考试人数：" & vbLf & "( 5～" & l & "范围内的奇数值 )", "系统提示", 5)
If x <> "" Then
   Set a = New Collection
   For i = 1 To y
      a.Add i
   Next i
   For i = 1 To Val(x)
f:
      n = Int(Rnd * a.Count) + 1
      s = Cells(a(n) + m, "B")
      If d(s) > 1 Then
         GoTo f:
      Else
          Cells(i + m, 4) = i
          Cells(i + m, 5) = s
          Cells(i + m, 6) = Cells(a(n) + m, "C")
          d(s) = d(s) + 1
          a.Remove (n)
      End If
   Next
End If
Set d = Nothing
End Sub

iaynidn.jiang

不是很理解，你想怎么做，还是改了一点，不知道对不对

yjh_27

1. If d(s) > 1 Then
   
2.          GoTo f:

复制代码

改为

1. If d(s) > 0 Then
   
2.          GoTo f:

复制代码

excelvlookup

Sub aa()
Set d = CreateObject("Scripting.Dictionary")
rw = Sheet1.Cells(Rows.Count, 1).End(3).Row
ar = Sheet1.Range("a3:c" & rw)
ReDim br(1 To UBound(ar), 1 To UBound(ar))
rs = Sheet1.Cells(1, 4)
ReDim cr(1 To rs, 1 To 3)
For i = 1 To UBound(ar)
    ky1 = ar(i, 2): ky2 = ar(i, 3)
    r1 = d(ky1)
    If r1 = "" Then
        s1 = s1 + 1
        d(ky1) = s1
        r1 = s1
        s2 = s2 + 1
    End If
    br(r1, UBound(ar)) = br(r1, UBound(ar)) + 1
    s2 = br(r1, UBound(ar))
    br(r1, s2) = i
Next
For i = 1 To rs
    n1 = Int(Rnd * (s1 - i)) + i
    r2 = br(n1, UBound(ar))
    n2 = Int(Rnd * r2) + 1
    cr(i, 1) = i
    cr(i, 2) = ar(br(n1, n2), 2)
    cr(i, 3) = ar(br(n1, n2), 3)
    For j = 1 To UBound(ar)
        t = br(i, j): br(i, j) = br(n1, j): br(n1, j) = t
    Next
Next
Sheet1.Range("d3").Resize(rs, 3) = cr
End Sub
这就是一个单位一人，人数不能超过单位数哈