Excel VBA员工互评开发：C、D列不同名的姓名分配需求

以下是满足你需求的完整VBA代码，已补充D列姓名分配的核心逻辑：

Sub assign2ndQR()
    Dim empNames As Variant
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim i As Long, arrIndex As Long
    
    ' 指定目标工作表，避免ActiveWorkbook切换导致错误
    Set ws = ActiveWorkbook.Sheets("employees")
    LastRow = ws.UsedRange.Rows.Count
    empNames = UniquesFromRange(ws.Range("A2:A" & LastRow))
    
    ' 处理空数组情况
    If UBound(empNames) = -1 Then
        Debug.Print "未找到有效姓名数据"
        Exit Sub
    End If
    
    arrIndex = 0 ' 初始化数组遍历索引
    ' 遍历D列（从第2行开始，假设第1行为表头）
    For i = 2 To LastRow
        ' 循环获取数组中的姓名，直到当前行C、D列姓名不同
        Do
            ws.Cells(i, "D").Value = empNames(arrIndex)
            arrIndex = arrIndex + 1
            ' 数组遍历完成后重置索引，实现循环复用
            If arrIndex > UBound(empNames) Then arrIndex = 0
            
            ' 特殊场景处理：数组仅含一个姓名且与C列重复，无法分配
            If UBound(empNames) = 0 And ws.Cells(i, "C").Value = empNames(arrIndex) Then
                Debug.Print "警告：第" & i & "行无法分配有效姓名，唯一可选姓名与C列重复"
                Exit Do
            End If
        Loop Until ws.Cells(i, "C").Value <> ws.Cells(i, "D").Value
    Next i
    
    Debug.Print "D列姓名分配任务完成"
End Sub

Function UniquesFromRange(Rng As Range)
    Dim d As Object, c As Range, tmp
    Set d = CreateObject("scripting.dictionary")
    For Each c In Rng.SpecialCells(xlCellTypeVisible).Cells
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then
            If Not d.Exists(tmp) Then d.Add tmp, 1
        End If
    Next c
    UniquesFromRange = d.keys
End Function

关键逻辑说明 #

• 数组循环复用：通过arrIndex变量遍历empNames数组，当索引超出数组上界时重置为0，实现数组的循环使用。
• 同行姓名去重：使用Do...Loop循环检查当前分配的姓名是否与C列同行姓名重复，若重复则自动取下一个数组元素，直到符合规则。
• 边界情况处理：当姓名数组仅包含一个元素，且该元素与当前行C列姓名相同时，输出警告并退出循环，避免无限死循环。
• 类型优化：将LastRow的类型从Integer改为Long，避免工作表行数超过32767时出现溢出错误。

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