修改Excel VBA随机抽名代码 适配列内姓名数不足预设值场景

场景说明 #

涉及2个工作表：

• Inscrp：按分类存储姓名，不同分类对应不同列，姓名从第3行开始录入
• Tirage：展示各分类随机抽取的姓名结果
  原代码预设单次抽取姓名数量为HowMany = 5，存在问题：当某列存储的有效姓名总数小于5时，Tirage表对应列直接返回空值。
  需求：无论每列存储的有效姓名总数是多少，都能完成不重复随机抽取，列内姓名数不足5时直接抽取全部有效姓名，不返回空结果。

原实现代码 #

Sub PickNamesAtRandom()
 Dim shI As Worksheet, lastR As Long, shT As Worksheet, HowMany As Long
 Dim rndNumber As Integer, Names() As String, i As Long, CellsOut As Long

 HowMany = 5: CellsOut = 8
 Set shI = Worksheets("Inscrp")
 Set shT = Worksheets("Tirage")

 Dim col As Long, arrCol, filt As String, nrCol As Long
 nrCol = shT.Cells(4, 8) 'number of columns to be returned. It can be changed and also be calculated...

 For col = 1 To nrCol
 
   
    lastR = shI.Cells(shI.Rows.Count, col).End(xlUp).Row 'last row in column to be processed
     
    If lastR >= HowMany + 2 Then  '+ 2 because the range is build starting with the third row...
        arrCol = Application.Transpose(shI.Range(shI.Cells(3, col), shI.Cells(lastR, col)).Value2) 'place the range in a 1D array
        
        ReDim Names(1 To HowMany) 'Set the array size to how many names required
        For i = 1 To UBound(Names)
tryAgain:
            Randomize
            rndNumber = Int((UBound(arrCol) - LBound(arrCol) + 1) * Rnd + LBound(arrCol))
            If arrCol(rndNumber) = "" Then GoTo tryAgain
            Names(i) = arrCol(rndNumber)
            filt = arrCol(rndNumber) & "##$$@": arrCol(rndNumber) = filt
            arrCol = Filter(arrCol, filt, False)   'eliminate the already used name from the array
        Next i
        shT.Cells(CellsOut, col).Resize(UBound(Names), 1).Value2 = Application.Transpose(Names)
    End If
 Next col
 MsgBox "Ready..."
End Sub

问题根因 #

原代码写死了准入判断If lastR >= HowMany + 2 Then，直接跳过了有效姓名数小于5的列，完全不进入抽取逻辑；同时结果数组大小固定为5，没有适配列内姓名不足的场景。

修复后代码 #

Sub PickNamesAtRandom()
    Dim shI As Worksheet, lastR As Long, shT As Worksheet, HowMany As Long
    Dim rndNumber As Integer, Names() As String, i As Long, CellsOut As Long
    Dim col As Long, arrCol, filt As String, nrCol As Long
    Dim validCount As Long, actualPick As Long

    HowMany = 5: CellsOut = 8
    Set shI = Worksheets("Inscrp")
    Set shT = Worksheets("Tirage")
    ' 清空历史抽取结果，避免残留数据干扰
    shT.Range(shT.Cells(CellsOut, 1), shT.Cells(shT.Rows.Count, shT.Columns.Count)).ClearContents
    
    nrCol = shT.Cells(4, 8) '需要处理的列总数

    For col = 1 To nrCol
        lastR = shI.Cells(shI.Rows.Count, col).End(xlUp).Row
        validCount = lastR - 2 '减去前2行表头，计算当前列有效姓名总数
        If validCount <= 0 Then GoTo NextCol '空列直接跳过
        
        ' 实际抽取数：有效数≥5时抽5个，不足5时抽全部
        actualPick = IIf(validCount < HowMany, validCount, HowMany)
        ' 读取当前列姓名转为1D数组
        arrCol = Application.Transpose(shI.Range(shI.Cells(3, col), shI.Cells(lastR, col)).Value2)
        ' 提前过滤数组中空值，减少无效重试
        arrCol = Filter(arrCol, "", False)
        
        ReDim Names(1 To actualPick) '按实际抽取数设置结果数组大小
        For i = 1 To UBound(Names)
tryAgain:
            Randomize
            rndNumber = Int((UBound(arrCol) - LBound(arrCol) + 1) * Rnd + LBound(arrCol))
            Names(i) = arrCol(rndNumber)
            ' 标记已抽取姓名，从待选数组移除保证不重复
            filt = arrCol(rndNumber) & "##$$@"
            arrCol(rndNumber) = filt
            arrCol = Filter(arrCol, filt, False)
        Next i
        ' 输出结果到Tirage对应列
        shT.Cells(CellsOut, col).Resize(UBound(Names), 1).Value2 = Application.Transpose(Names)
NextCol:
    Next col
    MsgBox "随机抽取完成"
End Sub

修复点说明 #

• 新增有效姓名数计算逻辑，自动识别每列实际存储的姓名总量
• 动态调整实际抽取数量：列内姓名≥5个时抽取5个不重复姓名，不足5个时抽取全部有效姓名，不会出现空结果
• 新增历史结果清空逻辑，避免上一次抽取的残留数据影响展示
• 提前过滤待选数组中的空单元格，减少随机抽取时的无效跳转重试

效果对比 #

原代码运行效果 #

Sheet1"Inscrp"                 Sheet2"Tirage"
A        B                     A        B
John     Simon                 David    "Nothing"  
David    Gerard                Steve       
Jacob    Herald                john     
Steve    Paul                  Sara
Sara                           Jacob

修复后期望运行效果 #

Sheet1"Inscrp"                 Sheet2"Tirage"
A        B                     A        B
John     Simon                 David    Gerard  
David    Gerard                Steve    Paul    
Jacob    Herald                john     Simon
Steve    Paul                  Sara     Herald
Sara                           Jacob

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