如何将Sheet1的Part均等分配给Sheet2的Analyst？现有VBA宏异常

需求说明 #

• Sheet1的A列（从A2开始）是**Part（部件）**列表，示例场景有5个部件
• Sheet2的A列（从A2开始）是**Analyst（分析师）**列表，示例场景有3名分析师
• 核心目标：将部件均等分配给分析师，保证每个分析师分到的数量尽可能接近（比如5个部件分给3人，2人分2个，1人分1个）

原代码问题分析 #

原代码的核心逻辑完全错误：

• 嵌套循环导致每个部件被重复分配给所有分析师，且写入位置严重错位（i + (j - 1) * lastRow1会把同一部件的分配结果写到表格末尾的空白行）
• 初始化的analystIndex变量完全未使用，根本没实现轮询分配的核心逻辑

修正后的VBA代码 #

Sub AssignAnalysts()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim partCount As Long, analystCount As Long
    Dim i As Long, currentAnalystIndex As Long
    
    ' 绑定目标工作表
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 获取两表数据的最后一行
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' 计算实际的部件和分析师数量（减去表头行）
    partCount = lastRow1 - 1
    analystCount = lastRow2 - 1
    
    ' 初始化当前分配的分析师索引（对应Sheet2的A2行）
    currentAnalystIndex = 1
    
    ' 遍历每个部件，从A2行开始
    For i = 2 To lastRow1
        ' 将当前分析师写入Sheet1的C列对应行
        ws1.Cells(i, "C").Value = ws2.Cells(currentAnalystIndex + 1, "A").Value
        
        ' 轮询切换下一位分析师，到最后一位后回到第一位
        currentAnalystIndex = currentAnalystIndex + 1
        If currentAnalystIndex > analystCount Then
            currentAnalystIndex = 1
        End If
    Next i
End Sub

修正要点说明 #

1. 简化逻辑：去掉无用的范围变量和嵌套循环，直接通过行号进行操作，降低复杂度
2. 轮询分配：用currentAnalystIndex实现循环切换分析师，遍历部件时依次分配给下一位，实现均等分配
3. 正确写入位置：将分析师直接写入对应部件行的C列，避免原代码的错位问题
4. 清晰计数：明确计算实际数据数量（减去表头行），避免索引混乱

示例分配效果（5部件+3分析师） #

（注：A1、A2各分到2个部件，A3分到1个，符合均等分配的要求）

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