Excel VBA实现按唯一分组随机抽取N条记录的问题咨询

公式方案（适合Excel 365/2021及以上版本） #

无需代码，操作门槛低，可随时刷新生成新样本：

• 新增分组键辅助列：假设6个分组字段（客户/承包商/配送中心/服务等级/告警值/状态）对应A-F列，第一行为表头，G2输入公式=A2&"|"&B2&"|"&C2&"|"&D2&"|"&E2&"|"&F2，下拉填充到所有数据行，生成唯一分组标识
• 新增随机值辅助列：H2输入公式=RAND()，下拉填充到所有数据行，生成分组内随机排序依据
• 新增分组内排名辅助列：I2输入公式=COUNTIFS(G:G,G2,H:H,">"&H2)+1，下拉填充到所有数据行，计算每条记录在对应分组内的随机排名
• 筛选I列数值小于等于抽取条数（示例中为5），得到的结果就是每个分组随机抽取的不重复记录，按F9刷新可重新生成随机样本

VBA方案（兼容全版本Excel，一键生成样本） #

适合每日批量生成样本的场景，无需手动操作辅助列：

1. 打开数据工作表，按Alt+F11调出VBA编辑器
2. 右键左侧当前工作簿名称，依次选择「插入」-「模块」
3. 将下方代码粘贴到模块窗口，按需修改顶部的配置参数（抽取条数、字段列范围、结果输出位置等）
4. 按F5运行即可直接生成独立的样本数据集

Sub 按分组随机抽取样本()
    ' ===== 以下参数可根据实际情况修改 =====
    Const 抽取条数 As Integer = 5 ' 每个分组需要抽取的记录数
    Const 分组字段起始列 As String = "A" ' 6个分组字段的第一列（客户所在列）
    Const 分组字段结束列 As String = "F" ' 6个分组字段的最后一列（状态所在列）
    Const 数据起始行 As Integer = 2 ' 数据首行行号（排除表头行）
    Const 结果输出起始单元格 As String = "K1" ' 样本数据输出的左上角位置
    ' ===== 以上参数可根据实际情况修改 =====
    
    Dim 数据数组, 分组字典 As Object, 临时列表, 结果数组, i As Long, j As Long, 分组键 As String
    Dim 随机索引 As Long, 剩余条数 As Long, 结果行号 As Long
    
    ' 读取全量数据到数组提升运行效率
    数据数组 = Range(Cells(数据起始行, 分组字段起始列).CurrentRegion, Cells(Rows.Count, 1).End(xlUp)).Value
    Set 分组字典 = CreateObject("Scripting.Dictionary")
    
    ' 按分组键归类所有记录的索引
    For i = 1 To UBound(数据数组, 1)
        分组键 = ""
        For j = Columns(分组字段起始列).Column To Columns(分组字段结束列).Column
            分组键 = 分组键 & "|" & 数据数组(i, j)
        Next
        If Not 分组字典.Exists(分组键) Then
            Set 分组字典(分组键) = CreateObject("System.Collections.ArrayList")
        End If
        分组字典(分组键).Add i
    Next
    
    ' 初始化结果数组，写入表头
    ReDim 结果数组(1 To 分组字典.Count * 抽取条数 + 1, 1 To UBound(数据数组, 2))
    For j = 1 To UBound(数据数组, 2)
        结果数组(1, j) = Cells(1, j).Value
    Next
    结果行号 = 2
    
    ' 逐分组随机抽取无重复记录
    For Each 分组键 In 分组字典.Keys
        Set 临时列表 = 分组字典(分组键)
        剩余条数 = Application.Min(抽取条数, 临时列表.Count) ' 分组记录不足抽取条数时全量取出
        For i = 1 To 剩余条数
            Randomize
            随机索引 = Int(Rnd * 临时列表.Count)
            ' 写入抽取到的记录
            For j = 1 To UBound(数据数组, 2)
                结果数组(结果行号, j) = 数据数组(临时列表(随机索引), j)
            Next
            临时列表.RemoveAt 随机索引 ' 移除已抽取记录避免重复
            结果行号 = 结果行号 + 1
        Next
    Next
    
    ' 输出结果到工作表并调整格式
    Range(结果输出起始单元格).Resize(UBound(结果数组, 1), UBound(结果数组, 2)).Value = 结果数组
    Range(结果输出起始单元格).CurrentRegion.EntireColumn.AutoFit
    MsgBox "样本抽取完成，共生成" & 结果行号 - 2 & "条记录", vbInformation
End Sub

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