|
本帖最后由 duquancai 于 2018-4-10 23:13 编辑
- Sub test()
- Dim k1, k2, r&, aData(), a(1 To 2, 1 To 2), fg As Boolean
- With Sheets("抽取结果")
- k1 = .[k3]: k2 = .[k4]
- .Range("a1:h" & .Cells(.Rows.Count, 1).End(3).Row).Offset(1).ClearContents
- If Not (IsNumeric(k1) * IsNumeric(k2) * (Len(k1) > 0 And Len(k2) > 0)) Then Exit Sub
- a(1, 1) = k1: a(2, 1) = k2: Set a(1, 2) = Sheets("技术类"): Set a(2, 2) = Sheets("商务类")
- For i = 1 To UBound(a)
- If Not fg Then
- ReDim aData(1 To a(i, 1), 1 To 8)
- If GetExpert(a(i, 2), aData, a(i, 1)) Then
- .Range("a2").Resize(a(i, 1), 8) = aData
- End If
- fg = True
- Else
- ReDim aData(1 To a(i, 1), 1 To 8)
- r = .Cells(.Rows.Count, 1).End(3).Row + 1
- If GetExpert(a(i, 2), aData, a(i, 1)) Then
- .Range("a" & r).Resize(a(i, 1), 8) = aData
- End If
- End If
- Next
- End With
- MsgBox "ok!抽取完毕!"
- End Sub
- Function GetExpert(ByVal sh As Worksheet, aData(), ByVal Gnu&) As Boolean
- Dim d As Object, r&, aRw(), arr, i&, j&
- r = sh.Cells(sh.Rows.Count, 1).End(3).Row
- Set d = CreateObject("Scripting.Dictionary")
- If Gnu > r - 1 Then GetExpert = False: Exit Function
- arr = sh.Range("a2:h" & r)
- Do While d.Count < Gnu
- d(CStr(Int(Rnd() * (r - 1) + 1))) = vbNullString
- Loop
- aRw = d.keys
- For i = 0 To Gnu - 1
- aData(i + 1, 1) = sh.Name
- For j = 2 To UBound(arr, 2)
- aData(i + 1, j) = arr(aRw(i), j)
- Next
- Next
- If i > 0 Then GetExpert = True
- End Function
复制代码 |
|