Question

这是我之前提出的问题的后续行动。我得到了答案，但由于我自己的经验不足和无能，我似乎无法正确实施。

我的情况如下：我需要为任务分配一份员工列表。

总会有比员工更多的任务。
每位员工必须至少分配一个
不应将员工分配到两个以上
我需要员工清单在分拣过程中随机化，以便相同的员工不会一遍又一遍地完成相同的任务

我现在要做的就是找到一种方法，开始“分配”员工，跟踪阵列（i）员工被分配的次数，如果它超过两次，则转到下一个。

一位很棒的用户试图在这里帮助我：Excel VBA to assign employees to tasks using loops

以下是我正在使用的“测试”表：

以下是我编写的用于对员工列表进行排序的宏，其工作原理如下：

Sub ShuffleEmp()
' This macro's intention is to shuffle the current liste of process assessors

    Application.ScreenUpdating = False
    Dim tempString As String, tempInteger As Integer, i As Integer, j As Integer, lastRow As Integer

    ' this grabs the last row with data, so that it can be dynamic
    With Sheets("Test")
        lastRow = .Range("M" & .Rows.Count).End(xlUp).Row
    End With

    ' this assumes ALWAYS 45 tasks
    ' starting row 6, going until row 35
    For i = 6 To lastRow
        ' row 6, column 14 (next to Emp column) to start....
        Cells(i, 14).Value = WorksheetFunction.RandBetween(0, 1000)
    Next i

        'now it has assigned random values...

    For i = 6 To lastRow
        For j = i + 1 To lastRow
            '14 is the number column...
            If Cells(j, 14).Value < Cells(i, 14).Value Then

                'change the string, which is the Emp column...
                tempString = Cells(i, 13).Value
                Cells(i, 13).Value = Cells(j, 13).Value
                Cells(j, 13).Value = tempString

                tempInteger = Cells(i, 14).Value
                Cells(i, 14).Value = Cells(j, 14).Value
                Cells(j, 14).Value = tempInteger
            End If
        Next j
    Next i

    Worksheets("Test").Range("N:N").EntireColumn.Delete

    Application.ScreenUpdating = True

End Sub

以下是将该列表转换为数组的宏：

Sub EmpArray()
' This stores the column of Emps as an array

    Dim Storage() As String ' initial storage array to take values
    Dim i As Long
    Dim j As Long
    Dim lrow As Long

    lrow = Cells(Rows.Count, "M").End(xlUp).Row ' The amount of stuff in the column

    ReDim Storage(1 To lrow - 5)

    For i = lrow To 6 Step -1
        If (Not IsEmpty(Cells(i, 13).Value)) Then ' checks to make sure the value isn't empty
            j = j + 1
            Storage(j) = Cells(i, 13).Value
        End If
    Next i

    ReDim Preserve Storage(1 To j)

    For j = LBound(Storage) To UBound(Storage)  ' loop through the previous array
        MsgBox (Storage(j))
    Next j


End Sub

Answer 1

这是你的整个计划。它经过测试和运作。唯一的问题是您的屏幕截图没有显示行和列标题，因此我不得不假设任务是B列，第1行。

这是您的主要子程序。这是您将按钮分配给的程序。这将自动检查您的employeeList是否未初始化（基本为空）并使用函数buildOneDimArr重建它。

Sub assignEmployeeTasks()

    Dim ws As Worksheet, i As Long
    Set ws = ThisWorkbook.Worksheets(1)
    Dim employeeList() As Variant

    With ws
        For i = 2 To lastRow(ws, 2)
            If (Not employeeList) = -1 Then
                'rebuild employeelist / array uninitialized
                employeeList = buildOneDimArr(ws, "F", 2, lastRow(ws, "F"))
            End If
            .Cells(i, 4) = randomEmployee(employeeList)
        Next
    End With

End Sub

这些是＆＃34;支持＆＃34;允许你的程序完成它的工作：

Function randomEmployee(ByRef employeeList As Variant) As String

    'Random # that will determine the employee chosen
    Dim Lotto As Long
    Lotto = randomNumber(LBound(employeeList), UBound(employeeList))
    randomEmployee = employeeList(Lotto)

    'Remove the employee from the original array before returning it to the sub
    Dim retArr() As Variant, i&, x&, numRem&
    numRem = UBound(employeeList) - 1
    If numRem = -1 Then     'array is empty
        Erase employeeList
        Exit Function
    End If
    ReDim retArr(numRem)
    For i = 0 To UBound(employeeList)
        If i <> Lotto Then
            retArr(x) = employeeList(i)
            x = x + 1
        End If
    Next i
    Erase employeeList
    employeeList = retArr

End Function

' This will take your column of employees and place them in a 1-D array
Function buildOneDimArr(ByVal ws As Worksheet, ByVal Col As Variant, _
        ByVal rowStart As Long, ByVal rowEnd As Long) As Variant()

    Dim numElements As Long, i As Long, x As Long, retArr()
    numElements = rowEnd - rowStart
    ReDim retArr(numElements)

    For i = rowStart To rowEnd
        retArr(x) = ws.Cells(i, Col)
        x = x + 1
    Next i

    buildOneDimArr = retArr

End Function

' This outputs a random number so you can randomly assign your employee
Function randomNumber(ByVal lngMin&, ByVal lngMax&) As Long
    'Courtesy of https://stackoverflow.com/a/22628599/5781745
    Randomize
    randomNumber = Int((lngMax - lngMin + 1) * Rnd + lngMin)
End Function

' This gets the last row of any column you specify in the arguments
Function lastRow(ws As Worksheet, Col As Variant) As Long
    lastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
End Function

您将要将所有这些放入标准模块中。

Answer 2

我为您创建了一个解决方案，它可以帮助您进一步发展以便对编程有所了解。

使用我的解决方案，你不需要事先洗牌你的员工，你会使用一些你以前可能没有用过的东西。首先，我创建了一个名为Employee的新类模块，如下所示：

Private p_name As String
Private p_task As String

Public Property Get Name() As String
    Name = p_name
End Property

Public Property Let Name(ByVal value As String)
p_name = value
End Property

Public Property Get Task() As String
    Task = p_task
End Property

Public Property Let Task(ByVal value As String)
p_task = value
End Property

这只是一个举办职业和任务的小班。在一个普通的模块中，我添加了一个名为ShuffleTasks的方法，其中包含2个集合作为参数。集合是一个稍微更舒适，因此稍微更重和更慢的阵列版本。

Private Sub ShuffleTasks(t As Collection, emp As Collection)
Dim i As Integer
Dim count As Integer
Dim employ As employee
count = emp.count
Dim remIndex  As Integer
For i = 1 To count
'randomize
Randomize
'get a random index from tasks by its count
remIndex = Int((t.count) * Rnd + 1)
'add the task to the employee list
emp.Item(i).Task = t.Item(remIndex)
'remove the task so it wont be assigned again
t.Remove (remIndex)
Next
End Sub

第一个参数是任务的集合（只是一个带有名称的字符串），第二个参数是员工的集合。第二个也将被用作结果。然后我遍历所有员工并生成1和任务计数之间的随机整数。我将任务添加到集合中的当前员工，并从任务列表中删除它。在下一次迭代中，任务数量将为-1，并从集合中的项目数量中再次随机选择。

然后我修改了你的EmpArray方法来填充工作表中的一些数据并调用ShuffleTasks方法

Sub EmpArray()
' This stores the column of Emps as an Collection

    Dim sEmployees As New Collection, sTasks As New Collection ' initial storage array to take values
    Dim i As Long
    Dim j As Long
    Dim s As Variant
    Dim lrow As Long
    Dim emp As employee
    lrow = Cells(Rows.count, "M").End(xlUp).Row ' The amount of stuff in the column

    For i = lrow To 6 Step -1
        If (Not IsEmpty(Cells(i, 13).value)) Then ' checks to make sure the value isn't empty
            j = j + 1
            'Storage(j) = Cells(i, 13).Value
            Set emp = New employee
            emp.Name = Cells(i, 13).value
            sEmployees.Add emp
        End If
    Next i
' This stores the column of Tasks as an Collection
' I assume it is column 9
lrow = Cells(Rows.count, "I").End(xlUp).Row ' The amount of stuff in the column
    For i = lrow To 6 Step -1
        If (Not IsEmpty(Cells(i, 9).value)) Then ' checks to make sure the value isn't empty
            j = j + 1
            sTasks.Add Cells(i, 9).value

        End If
    Next i
ShuffleTasks sTasks, sEmployees
For Each emp In sEmployees
    Debug.Print (emp.Name & ": " & emp.Task)
Next

End Sub

正如您所看到的，对集合的修改将在每次新员工姓名和任务时显示。请记住，它不是随机的。在ShuffleTasks方法之后，任务集合将具有更少的项目。我只是想向您展示一种基本上与vba中的数据一起工作的方法。您只从表单加载数据，然后在纯vba对象中操作它。结果也可以写回工作表，我只需将它们打印到vba编辑器中的Debug Window。

希望这会有所帮助。这肯定是一个快速而肮脏的解决方案，我也没有涵盖收集的所有方面，也没有涵盖参数和ByVal与ByRef等。但也许这会激发你一点点;）

Answer 3

我希望我理解正确：

Sub AssignEmpl() 
    Dim TaskTable As Range, EmpTable As Range 
    Dim lRowT As Long, lRowE As Long, iCell As Range 
    lRowT = Worksheets("Test").Range("I" & Worksheets("Test").Rows.Count).End(xlUp).Row 
    lRowE = Worksheets("Test").Range("M" & Worksheets("Test").Rows.Count).End(xlUp).Row 
    ' Don't know what are actual ranges, modify 
    Set TaskTable = Worksheets("Test").Range("I6:K" & lRowT) 
    Set EmpTable = Worksheets("Test").Range("M6:M" & lRowE) 
    ' Starting loop 
    Do 
        ' Populate column with random nubmers between 1 and number of employees 
        ' 5 is a number of employees (essentialy lRowE - 5 or something like that) 
        TaskTable.Columns(3).Formula = "=RANDBETWEEN(1," & lRowE - 5 & ")" 
        ' Remove formula (so it doesn't recalculate) 
        TaskTable.Columns(3).Value = TaskTable.Columns(3).Value 
        ' Check if any number appears more than 2 times 
    Loop While Evaluate("AND(MAX(COUNTIF(" & TaskTable.Columns(3).Address & "," & TaskTable.Columns(3).Address & "))>2)") 
    '    Put these employee in there
    For Each iCell In TaskTable.Columns(3).Cells 
        iCell.Value = EmpTable.Cells(iCell.Value, 1) 
    Next 
End Sub

随机将员工分配给任务

3 个答案: