Excel VBA员工任务分配逻辑开发求助：每人至少1至多2任务

看起来你已经有了不错的思路基础，咱们把这个员工任务分配的逻辑和代码完善起来，刚好能满足你45个任务、30名员工（每人1-2个任务）的需求。

优化后的核心逻辑 #

你的初始思路没问题，咱们调整得更高效一点：

• 第一步：提取唯一员工列表（确保没有重复），先给每个员工分配1个任务（用随机打乱后的顺序对应前30个任务）
• 第二步：重新打乱员工列表，然后给剩下的15个任务分配，直到每个员工最多2个任务为止
• 这样既能保证每人至少1个，又能随机分配剩余任务，完全符合你的要求

完整VBA代码实现 #

我把代码拆成了几个子过程，方便维护和理解：

Option Explicit

' 主过程：整合所有分配步骤
Sub AssignTasksToEmployees()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Test")
    
    Dim lastTaskRow As Integer, lastEmployeeRow As Integer
    lastTaskRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' 任务最后一行（Task列）
    lastEmployeeRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row ' 员工列表最后一行
    
    ' 1. 提取并打乱员工列表
    Dim employeeList As Variant
    employeeList = GetUniqueEmployeeList(ws, 6, lastEmployeeRow) ' 从第6行开始
    ShuffleArray employeeList ' 随机打乱
    
    ' 2. 先给每个员工分配1个任务（前30个任务）
    Dim taskCounter As Integer, empCounter As Integer
    Dim taskCountDict As Object
    Set taskCountDict = CreateObject("Scripting.Dictionary")
    
    ' 初始化字典，记录每个员工的任务数为0
    For empCounter = LBound(employeeList) To UBound(employeeList)
        taskCountDict(employeeList(empCounter)) = 0
    Next empCounter
    
    ' 分配第一个任务
    For taskCounter = 6 To 6 + UBound(employeeList) ' 前30个任务行（假设任务从第6行开始）
        If taskCounter > lastTaskRow Then Exit For ' 防止任务数不足
        Dim empName As String
        empName = employeeList(taskCounter - 6) ' 对应打乱后的员工
        ws.Cells(taskCounter, "E").Value = empName ' Assignee列是E列
        taskCountDict(empName) = taskCountDict(empName) + 1
    Next taskCounter
    
    ' 3. 重新打乱员工列表，分配剩余任务
    ShuffleArray employeeList
    Dim remainingTasks As Integer
    remainingTasks = lastTaskRow - (6 + UBound(employeeList)) ' 剩余任务数：45-30=15
    
    Dim remainingCounter As Integer
    remainingCounter = 0
    empCounter = LBound(employeeList)
    
    Do While remainingCounter < remainingTasks And empCounter <= UBound(employeeList)
        empName = employeeList(empCounter)
        ' 如果该员工任务数还没到2，就分配
        If taskCountDict(empName) < 2 Then
            taskCounter = taskCounter + 1
            ws.Cells(taskCounter, "E").Value = empName
            taskCountDict(empName) = taskCountDict(empName) + 1
            remainingCounter = remainingCounter + 1
        End If
        empCounter = empCounter + 1
        ' 遍历完一轮员工列表后，重新打乱再继续（如果还有剩余任务）
        If empCounter > UBound(employeeList) Then
            ShuffleArray employeeList
            empCounter = LBound(employeeList)
        End If
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "任务分配完成！"
End Sub

' 辅助函数：提取唯一的员工列表
Function GetUniqueEmployeeList(ws As Worksheet, startRow As Integer, endRow As Integer) As Variant
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim i As Integer
    For i = startRow To endRow
        Dim empName As String
        empName = Trim(ws.Cells(i, "F").Value) ' Employee List是F列
        If empName <> "" And Not dict.Exists(empName) Then
            dict.Add empName, empName
        End If
    Next i
    
    GetUniqueEmployeeList = dict.Keys
End Function

' 辅助函数：Fisher-Yates洗牌算法（高效随机打乱数组）
Sub ShuffleArray(arr As Variant)
    Dim i As Integer, j As Integer, temp As Variant
    Randomize ' 初始化随机数生成器
    
    For i = UBound(arr) To LBound(arr) Step -1
        j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr))
        ' 交换元素
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
    Next i
End Sub

代码关键点说明 #

1. Fisher-Yates洗牌算法：比你原来用的冒泡排序+随机数列的方式更高效、更公平，专门用于随机打乱数组，避免排序带来的性能损耗。
2. Dictionary对象：用来跟踪每个员工的已分配任务数，快速判断是否还能分配更多任务，比遍历表格统计要高效得多。
3. 分步分配：先保证每人至少1个任务，再分配剩余任务，完全符合你的需求（30员工×1 + 15员工×1 = 45任务）。
4. 边界处理：加入了任务数不足的判断，避免出现数组越界的错误。

注意事项 #

• 确保你的表格中，Assignee列是E列，Employee List是F列，任务从第6行开始（如果你的行号或列号不同，修改代码里的对应位置即可）。
• 运行主过程AssignTasksToEmployees即可完成分配，不需要单独运行原来的ShufflePA过程。

内容的提问来源于stack exchange，提问作者artemis