完整VBA代码 #

Sub 按条件随机抽样()
    Dim wsSource As Worksheet, wsCriteria As Worksheet, wsResult As Worksheet
    Dim lastRowSource As Long, lastRowCriteria As Long
    Dim i As Long, j As Long, sampleCount As Long
    Dim nameToSample As String
    Dim rowList As Collection
    Dim randomIndex As Integer, tempRow As Long
    
    ' 指定工作表对象
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' 原始数据工作表
    Set wsCriteria = ThisWorkbook.Sheets("Sheet2") ' 抽样条件工作表
    
    ' 创建或复用结果工作表
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("抽样结果")
    If Err.Number <> 0 Then
        Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsResult.Name = "抽样结果"
    End If
    On Error GoTo 0
    wsResult.Cells.Clear ' 清空旧数据
    
    ' 复制表头到结果表
    wsSource.Range("A1:B1").Copy wsResult.Range("A1")
    
    ' 获取工作表最后一行行号
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowCriteria = wsCriteria.Cells(wsCriteria.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历抽样条件表中的每个姓名
    For i = 2 To lastRowCriteria
        nameToSample = wsCriteria.Cells(i, "A").Value
        sampleCount = wsCriteria.Cells(i, "B").Value
        
        If sampleCount > 0 Then
            Set rowList = New Collection
            
            ' 收集当前姓名对应的所有原始数据行号
            For j = 2 To lastRowSource
                If wsSource.Cells(j, "A").Value = nameToSample Then
                    rowList.Add j
                End If
            Next j
            
            ' 处理抽样逻辑
            If rowList.Count >= sampleCount Then
                ' Fisher-Yates洗牌算法打乱行号，保证随机性
                For j = rowList.Count To 2 Step -1
                    randomIndex = Int((j - 1) * Rnd + 1)
                    tempRow = rowList(j)
                    rowList(j) = rowList(randomIndex)
                    rowList(randomIndex) = tempRow
                Next j
                
                ' 复制指定数量的随机行到结果表
                For j = 1 To sampleCount
                    wsSource.Rows(rowList(j)).Copy wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Offset(1, 0)
                Next j
            Else
                ' 记录不足时的处理：抽取全部并提示
                MsgBox "姓名【" & nameToSample & "】仅" & rowList.Count & "条记录，不足要求的" & sampleCount & "条，已全部抽取"
                For j = 1 To rowList.Count
                    wsSource.Rows(rowList(j)).Copy wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Offset(1, 0)
                Next j
            End If
        End If
    Next i
    
    ' 自动调整结果表列宽
    wsResult.Columns("A:B").AutoFit
    
    MsgBox "抽样完成，结果已保存到【抽样结果】工作表"
End Sub

代码关键说明 #

• 工作表管理：自动创建或复用结果工作表，避免手动新建的麻烦
• 行号收集：通过集合存储目标姓名的所有数据行号，后续随机抽取更高效
• 随机算法：使用Fisher-Yates洗牌打乱行号，确保抽样的真随机性，不会出现重复抽取
• 边界处理：针对记录数量不足的情况，自动抽取全部数据并给出提示
• 格式优化：抽样完成后自动调整列宽，提升结果可读性

使用步骤 #

1. 确保Excel文件中Sheet1（A列姓名、B列案件编号）和Sheet2（A列姓名、B列抽样数量）的结构符合要求
2. 按Alt + F11打开VBA编辑器
3. 右键点击工程资源管理器中的文件，选择【插入】→【模块】
4. 将上述代码粘贴到模块中
5. 按F5运行代码，或回到Excel界面通过【开发工具】→【宏】选择按条件随机抽样执行

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