如何用VBA按条件随机抽取指定数量客户并标记

默认你的数据结构为：A列存储客户基础信息，B列存储客户类型（A/B/C），C列用来填写选中标记y，数据从第2行开始，第1行为表头。

方案1：公式实现（无需写代码，适合普通用户） #

• 步骤1：新增辅助列D，在D2单元格输入公式=RAND()，下拉填充到所有客户行，生成随机数用于随机排序
• 步骤2：在C2单元格输入对应公式，下拉填充到所有行：
  如果你使用的是365/2021及以上版本Excel，支持FILTER函数，用以下公式：

  =IF(B2="A",IF(RANK(D2,FILTER($D$2:$D$101,$B$2:$B$101="A"),1)<=3,"y",""),IF(B2="B",IF(RANK(D2,FILTER($D$2:$D$101,$B$2:$B$101="B"),1)<=2,"y",""),IF(B2="C",IF(RANK(D2,FILTER($D$2:$D$101,$B$2:$B$101="C"),1)<=30,"y",""),"")))
  

  如果你使用的是旧版Excel，先按B列排序将三类客户分开，再分别对每类客户的D列随机数做排名，判断排名是否在抽取名额内即可。
• 步骤3：按F9可以刷新随机抽取结果，确定最终结果后，选中C列所有内容，右键选择「粘贴为值」，避免后续误操作刷新变动结果。

方案2：VBA脚本实现（一键执行，结果自动固定） #

• 步骤1：按Alt+F11打开VBA编辑器，右键点击当前工作簿名称，选择「插入」-「模块」
• 步骤2：将以下代码粘贴到模块编辑框中：

Sub 随机抽取客户()
    Dim ws As Worksheet
    Dim lastRow As Long, aCount As Long, bCount As Long, cCount As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ' 清空原有标记
    ws.Range("C2:C" & lastRow).ClearContents
    
    ' 校验客户数量是否满足抽取要求
    aCount = Application.WorksheetFunction.CountIf(ws.Range("B2:B" & lastRow), "A")
    bCount = Application.WorksheetFunction.CountIf(ws.Range("B2:B" & lastRow), "B")
    cCount = Application.WorksheetFunction.CountIf(ws.Range("B2:B" & lastRow), "C")
    If aCount < 3 Or bCount < 2 Or cCount < 30 Then
        MsgBox "存在类型客户数量不足，无法完成抽取"
        Exit Sub
    End If
    
    ' 按类型分别抽取
    Call ExtractByType(ws, "A", 3, lastRow)
    Call ExtractByType(ws, "B", 2, lastRow)
    Call ExtractByType(ws, "C", 30, lastRow)
    
    MsgBox "抽取完成，标记已填入C列"
End Sub

Sub ExtractByType(ws As Worksheet, targetType As String, needNum As Long, lastRow As Long)
    Dim cell As Range, rowArr() As Long, i As Long, rndIndex As Long, temp As Long
    ' 收集对应类型所有客户的行号
    i = 0
    For Each cell In ws.Range("B2:B" & lastRow)
        If cell.Value = targetType Then
            ReDim Preserve rowArr(i)
            rowArr(i) = cell.Row
            i = i + 1
        End If
    Next
    ' 洗牌算法打乱行号顺序
    Randomize
    For i = UBound(rowArr) To LBound(rowArr) Step -1
        rndIndex = Int((i - LBound(rowArr) + 1) * Rnd + LBound(rowArr))
        temp = rowArr(i)
        rowArr(i) = rowArr(rndIndex)
        rowArr(rndIndex) = temp
    Next
    ' 给抽取到的行填标记
    For i = 0 To needNum - 1
        ws.Cells(rowArr(i), "C").Value = "y"
    Next
End Sub

• 步骤3：关闭VBA编辑器回到Excel界面，按Alt+F8调出宏窗口，选择「随机抽取客户」点击执行即可。

注意事项 #

• 操作前请先备份原有数据，避免误操作导致内容丢失
• 如果你的类型列、标记列不是B列和C列，对应修改公式或代码里的列标识即可

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