如何用VBA为班组日均作业量排名（1-10，不打乱原有数据）

嘿，我完全懂你的需求——不想破坏原有数据的关联排序，又要给10个班组按日均作业量从高到低分配1-10的排名对吧？其实不用动原数据的排序，咱们可以用临时数组存关键信息+排序临时数据+写回排名的思路来实现，完美解决你的问题。

核心思路 #

1. 先把每个班组的「日均作业量」和「原行号」提取到临时数组里（原行号是关键，用来定位写回排名的位置）
2. 对临时数组按日均作业量降序排序
3. 根据临时数组里的原行号，把排名逐个写回原表对应的行，原数据顺序完全不动

完整VBA代码 #

Sub AssignTeamRankWithoutSorting()
    Dim targetSheet As Worksheet
    Dim lastDataRow As Long
    Dim tempDataArr() As Variant
    Dim i As Long, j As Long
    Dim swapTemp As Variant
    
    ' 替换成你的实际工作表名称
    Set targetSheet = ThisWorkbook.Worksheets("班组数据")
    
    ' 假设班组ID在A列，找到数据最后一行（表头在第1行）
    lastDataRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 初始化临时数组：存储[班组ID, 日均作业量, 原行号]
    ReDim tempDataArr(1 To lastDataRow - 1, 1 To 3)
    For i = 2 To lastDataRow
        tempDataArr(i - 1, 1) = targetSheet.Cells(i, "A").Value ' 班组ID列，按需修改
        tempDataArr(i - 1, 2) = targetSheet.Cells(i, "D").Value ' 日均作业量列，按需修改
        tempDataArr(i - 1, 3) = i ' 记录当前行的行号，用来写回排名
    Next i
    
    ' 对临时数组按日均作业量降序排序（冒泡排序，适合10条数据的小场景）
    For i = 1 To UBound(tempDataArr, 1) - 1
        For j = i + 1 To UBound(tempDataArr, 1)
            If tempDataArr(i, 2) < tempDataArr(j, 2) Then
                ' 交换班组ID
                swapTemp = tempDataArr(i, 1)
                tempDataArr(i, 1) = tempDataArr(j, 1)
                tempDataArr(j, 1) = swapTemp
                
                ' 交换日均作业量
                swapTemp = tempDataArr(i, 2)
                tempDataArr(i, 2) = tempDataArr(j, 2)
                tempDataArr(j, 2) = swapTemp
                
                ' 交换原行号
                swapTemp = tempDataArr(i, 3)
                tempDataArr(i, 3) = tempDataArr(j, 3)
                tempDataArr(j, 3) = swapTemp
            End If
        Next j
    Next i
    
    ' 将排名写入原表的指定列（这里用E列，按需修改）
    For i = 1 To UBound(tempDataArr, 1)
        targetSheet.Cells(tempDataArr(i, 3), "E").Value = i
    Next i
    
    MsgBox "排名已成功分配！", vbInformation
End Sub

代码调整说明 #

• 工作表和列修改：你需要把代码里的"班组数据"改成你的实际工作表名称，同时调整班组ID、日均作业量的列号（比如日均在C列就把"D"改成"C"），排名写入的列也可以换成你需要的列（比如"F"）。
• 排序逻辑：因为只有10个班组，用冒泡排序完全足够，代码简单易读。如果后续班组数量增加，可以换成更高效的排序算法，但10条数据没必要。

处理并列排名的进阶版本 #

如果遇到多个班组日均作业量相同的情况，上面的代码会按原数据出现顺序给先后排名。如果你想给并列班组相同排名，可以把最后一步的排名写入代码换成下面这段：

' 处理并列排名：相同日均的班组获得同一排名
Dim currentRank As Long, previousValue As Variant
currentRank = 1
previousValue = tempDataArr(1, 2)
targetSheet.Cells(tempDataArr(1, 3), "E").Value = currentRank

For i = 2 To UBound(tempDataArr, 1)
    If tempDataArr(i, 2) = previousValue Then
        ' 和上一个日均相同，用同一个排名
        targetSheet.Cells(tempDataArr(i, 3), "E").Value = currentRank
    Else
        ' 日均不同，更新排名和基准值
        currentRank = i
        targetSheet.Cells(tempDataArr(i, 3), "E").Value = currentRank
        previousValue = tempDataArr(i, 2)
    End If
Next i

这段代码会让并列班组共享同一排名，后续不同的班组会跳过重复的排名数（比如两个第2名，下一个直接是第4名）。如果想要并列但排名连续（两个第2名，下一个是第3名），只需要把currentRank = i改成currentRank = currentRank + 1即可。

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