Excel实现零件号无重复随机分发 全量循环前不重复方法咨询

原方法失效原因 #

• 你之前用的RemoveDuplicates方法仅能删除选定区域内的重复行，无法实现「识别I列已分配零件、从A列待选池移除对应条目」的逻辑，和需求完全不匹配。
• 原=@INDEX($A$1:$A$1178,RANK(B2,$B$1:$B$1178))公式未做已分配零件过滤，全范围抽取必然出现重复；手动清空单元格后公式引用范围出现空值，RANK匹配空行就会返回0值。

方案1：纯公式实现（无需写代码，按F9即可刷新） #

不需要修改A列原始零件数据，通过辅助列过滤已分配条目即可实现无重复抽取：

1. 保留A列全量1179个零件号，B列全行填充=RAND()到B1179，用于生成随机排序权重。
2. 新增J列作为辅助列（后续可直接隐藏），J2单元格输入以下公式后下拉填充到J1179，用于标记零件是否已被分配：

=IF(COUNTIF($I$2:$I$126,A2)>0,1,0)

注意：$I$2:$I$126是I列125个待填充单元格的实际范围，可根据你表格的I列起止行自行调整
3. I列从I2单元格开始，输入以下公式后下拉/右拉填充到全部125个单元格：

• 如果你用的是Excel 365/2021及以上版本，直接回车即可生效
• 如果你用的是旧版Excel，输入完按Ctrl+Shift+Enter确认数组公式

=IFERROR(INDEX($A:$A,AGGREGATE(15,6,ROW($A$2:$A$1179)/($J$2:$J$1179=0),RANK(B2,$B$2:$B$1179))),"本轮全部分配完成")

公式逻辑：自动过滤掉J列标记为已分配的零件，仅从未分配零件池中按B列随机权重排序抽取，按F9触发B列随机值重算时，会从未分配池重新抽取125个不重复零件，直到所有零件完成一轮分配。公式自带容错，剩余零件不足时会直接提示分配完成，不会返回0值。

方案2：VBA实现（适合需要固化分配记录的场景） #

如果需要每次抽取后自动把已分配零件从待选池永久移除，用以下代码替换你原来的宏即可，可给宏指定快捷键或绑定按钮，点击一次就完成一轮抽取：

Sub 随机分配无重复零件()
    Dim ws As Worksheet
    Dim partRng As Range
    Dim partArr, resArr(1 To 125, 1 To 1)
    Dim i As Long, randIdx As Long, temp As Variant
    Dim lastPartRow As Long
    
    Set ws = ActiveSheet
    ' 获取A列最后一个有零件号的行号
    lastPartRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastPartRow < 2 Then
        MsgBox "A列无待分配零件，请先补全零件列表"
        Exit Sub
    End If
    ' 读取所有剩余待分配零件到数组
    Set partRng = ws.Range("A2:A" & lastPartRow)
    partArr = partRng.Value
    ' 清空I列原有分配结果
    ws.Range("I2:I126").ClearContents
    
    ' Fisher-Yates洗牌算法随机抽取125个不重复零件
    Randomize
    For i = 1 To 125
        If i > UBound(partArr) Then
            resArr(i, 1) = "剩余零件不足，分配完成"
            Exit For
        End If
        randIdx = Int((UBound(partArr) - i + 1) * Rnd + i)
        temp = partArr(i, 1)
        partArr(i, 1) = partArr(randIdx, 1)
        partArr(randIdx, 1) = temp
        resArr(i, 1) = partArr(i, 1)
    Next i
    
    ' 写入抽取结果到I列
    ws.Range("I2").Resize(125, 1).Value = resArr
    
    ' 将未被抽取的剩余零件写回A列，移除已抽取零件
    If UBound(partArr) > 125 Then
        ws.Range("A2").Resize(UBound(partArr) - 125, 1).Value = _
            Application.Index(partArr, Evaluate("ROW(126:" & UBound(partArr) & ")"), 1)
        ws.Range("A" & 2 + UBound(partArr) - 125 & ":A" & lastPartRow).ClearContents
    Else
        ws.Range("A2:A" & lastPartRow).ClearContents
    End If
End Sub

该代码用经典洗牌算法保证抽取结果完全随机无重复，抽取完成后自动清理A列已用零件，不会出现重复抽取、返回0值的问题。

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