Question

我正尝试从每天8个任务中随机为11名员工设置工作分配。在这8个任务中，一项需要选择4次，一项需要选择2次，而其他六项任务只需选择一次。由于只有8个任务和11名员工，因此六个单独选择的任务中的一些可以被选择两次。我一直在尝试使用加权系统，但效果很好，但是我觉得应该有一种方法可以在仍使用加权系统的同时做我想做的事情（也许不是），我只是想不通如何设置限制每个随机选择的项目。任何帮助将不胜感激。

我已经尝试了For循环，Case和IF / Then，但无法进行任何操作。我列出的代码目前可以进行随机选择，但有时会涉及一项或多项的过多或过少。

Option Explicit

Private Sub CommandButton1_Click()
Dim RandomName As String
Dim Row As Long
Dim R As Range
Dim cell As Range
Dim upperBound As Integer
Dim lowerBound As Integer

'RandomName = Range("I2").value
Set R = Range("I2:I12")

'upperBound = 20
'lowerBound = 5

'RandomName = WeightedRnd(Array("Lamination", "Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(20, 18, 20, 8, 8, 10, 5, 11))

For Each cell In R
cell.value = WeightedRnd(Array("Lamination", "Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(25, 17, 19, 7, 8, 9, 5, 10))

'    If RandomName Like "*Lamination*" = 4 Then
'        cell.value = WeightedRnd(Array("Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(25, 25, 10, 10, 10, 5, 15))
    'cell.value = RandomName 'Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
'    End If
'Worksheets("Crew").Cells(Row, 1).value = RandomName
Next cell
'Range("I2", Row + 1, 11).value = RandomName
End Sub

Function WeightedRnd(items As Variant, weights As Variant) As Variant
Dim myItems(1 To 100) As Variant
Dim weight As Variant
Dim item As Variant
Dim myNumber As Variant
Dim i As Integer
Dim n As Integer
Dim p As Integer
Dim pick As Integer

i = 1
n = 0

For Each weight In weights
    For p = 1 To weight
       myItems(i) = items(n)
       i = i + 1
    Next
    n = n + 1
Next

n = UBound(myItems) - LBound(myItems) + 1
pick = getRandom(1, n)
WeightedRnd = myItems(pick)
End Function

Function getRandom(lowerBound, upperBound)
Randomize
getRandom = Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
End Function

Answer 1

不要考虑列表中的8个任务，而是考虑12个任务（其中一些是重复的）。根据您的需要，您可能需要考虑两个列表-前6个是两个重复的任务，然后其余6个是单个任务。拆分方式取决于您的限制和条件。

现在，您可以从列表中随机选择（一旦选择，就从列表中删除一个项目）并符合您的限制/标准。

Answer 2

感谢大家参观并尝试提供帮助。正如AJD所指出的，尝试另一种途径来获得我想要的，这就是我所做的，并在https://answers.microsoft.com/en-us/msoffice/forum/all/vba-coding-help-random-selection-from-list-without/f281278d-1acc-47c0-8f1b-7054bd6d538a找到了我需要的答案。

此处的代码：

Sub RangeRandomize()
 Dim SrcRange As Range, FillRange As Range
 Dim c As Range, r As Long
 Set SrcRange = Application.InputBox("Select source names", Type:=8)
 Set FillRange = Application.InputBox("Select Fill range", Type:=8)
 If FillRange.Cells.Count > SrcRange.Cells.Count Then
 MsgBox "Fill range too large"
 Exit Sub
 End If
 r = SrcRange.Cells.Count
 For Each c In FillRange
 Do
 c.Value = WorksheetFunction.Index(SrcRange, Int((r * Rnd) + 1))
 Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
 Next
 End Sub

将SrcRange和FillRange更改为特定范围并添加清晰的内容行即可满足我的需求。

谢谢！

VBA需要将随机选择的次数限制为x次

2 个答案: