基于多条件按审计人员-区域维度随机提取指定行数的VBA代码需求

没问题，我帮你搞定这个审计数据提取的需求，下面是一段量身定制的VBA代码，完全贴合你描述的规则——按审计人员+区域分组，每组先捞完所有valid行，剩下的名额从其他决策行里随机补够27行，还加了详细注释方便你调整。

核心逻辑说明 #

• 用字典对数据按「审计人员（A列）+区域（C列）」进行分组，确保每个组合单独处理
• 每个分组先提取所有T列=valid的行，这部分是必选的
• 计算还需要补充的行数：27 - valid行数量，如果这个数大于0，就从该分组的非valid行里随机抽取对应数量的行（避免重复抽取）
• 把每组的结果合并后一次性复制到目标工作表，比逐行复制效率高很多

VBA代码实现 #

Sub ExtractAuditData()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, targetRow As Long
    Dim groupDict As Object, key As String
    Dim validRows As Range, otherRows As Range, randomRows As Range
    Dim validCount As Integer, needRandomCount As Integer
    Dim randomIndex As Integer, tempArr() As Integer, arrIndex As Integer
    
    ' 设置源工作表和目标工作表（如果目标表不存在则创建）
    Set wsSource = ThisWorkbook.Worksheets("源数据") ' 替换成你的源表名称
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Worksheets("提取结果")
    If Err.Number <> 0 Then
        Set wsTarget = ThisWorkbook.Worksheets.Add(After:=wsSource)
        wsTarget.Name = "提取结果"
        ' 复制表头到目标表
        wsSource.Rows(1).Copy wsTarget.Rows(1)
        targetRow = 2
    Else
        ' 清空目标表已有数据（保留表头）
        wsTarget.Range("A2:" & wsTarget.Cells(wsTarget.Rows.Count, wsTarget.Columns.Count).Address).ClearContents
        targetRow = 2
    End If
    On Error GoTo 0
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set groupDict = CreateObject("Scripting.Dictionary")
    
    ' 第一步：遍历源数据，按审计人员+区域分组，记录每组的valid行和其他行
    For i = 2 To lastRow ' 假设第一行是表头
        key = wsSource.Cells(i, "A").Value & "|" & wsSource.Cells(i, "C").Value ' 用|分隔两个条件作为字典键
        
        If wsSource.Cells(i, "T").Value = "valid" Then
            ' 加入valid行集合
            If groupDict.Exists(key) Then
                Set validRows = groupDict(key)(0)
                Set validRows = Union(validRows, wsSource.Rows(i))
                groupDict(key)(0) = validRows
            Else
                Set validRows = wsSource.Rows(i)
                Set otherRows = Nothing
                groupDict.Add key, Array(validRows, otherRows)
            End If
        Else
            ' 加入其他行集合
            If groupDict.Exists(key) Then
                Set otherRows = groupDict(key)(1)
                If otherRows Is Nothing Then
                    Set otherRows = wsSource.Rows(i)
                Else
                    Set otherRows = Union(otherRows, wsSource.Rows(i))
                End If
                groupDict(key)(1) = otherRows
            Else
                Set validRows = Nothing
                Set otherRows = wsSource.Rows(i)
                groupDict.Add key, Array(validRows, otherRows)
            End If
        End If
    Next i
    
    ' 第二步：处理每个分组，提取符合要求的行
    Randomize ' 初始化随机数生成器
    For Each key In groupDict.Keys
        Set validRows = groupDict(key)(0)
        Set otherRows = groupDict(key)(1)
        validCount = 0
        needRandomCount = 0
        
        ' 计算valid行数量
        If Not validRows Is Nothing Then
            validCount = validRows.Rows.Count
        End If
        
        ' 计算需要随机抽取的行数
        needRandomCount = 27 - validCount
        
        ' 情况1：valid行已经≥27，直接复制所有valid行
        If validCount >= 27 Then
            validRows.Copy wsTarget.Rows(targetRow)
            targetRow = targetRow + validRows.Rows.Count
        Else
            ' 先复制所有valid行
            If Not validRows Is Nothing Then
                validRows.Copy wsTarget.Rows(targetRow)
                targetRow = targetRow + validCount
            End If
            
            ' 如果需要补充随机行，且存在其他行
            If needRandomCount > 0 And Not otherRows Is Nothing Then
                Dim otherCount As Integer
                otherCount = otherRows.Rows.Count
                
                ' 如果其他行数量不够，就取全部
                If otherCount <= needRandomCount Then
                    otherRows.Copy wsTarget.Rows(targetRow)
                    targetRow = targetRow + otherCount
                Else
                    ' 生成不重复的随机索引
                    ReDim tempArr(1 To needRandomCount)
                    arrIndex = 1
                    Do While arrIndex <= needRandomCount
                        randomIndex = Int((otherCount) * Rnd + 1)
                        ' 检查索引是否已存在
                        Dim isDuplicate As Boolean
                        isDuplicate = False
                        For j = 1 To arrIndex - 1
                            If tempArr(j) = randomIndex Then
                                isDuplicate = True
                                Exit For
                            End If
                        Next j
                        If Not isDuplicate Then
                            tempArr(arrIndex) = randomIndex
                            arrIndex = arrIndex + 1
                        End If
                    Loop
                    
                    ' 根据随机索引提取行
                    Set randomRows = otherRows.Rows(tempArr(1))
                    For j = 2 To needRandomCount
                        Set randomRows = Union(randomRows, otherRows.Rows(tempArr(j)))
                    Next j
                    
                    ' 复制随机行到目标表
                    randomRows.Copy wsTarget.Rows(targetRow)
                    targetRow = targetRow + needRandomCount
                End If
            End If
        End If
    Next key
    
    MsgBox "数据提取完成！结果已保存到「提取结果」工作表。", vbInformation
End Sub

关键细节说明 #

1. 分组方式：用Scripting.Dictionary来存储每个「审计人员+区域」组合的valid行和其他行，键用姓名|区域的格式避免冲突
2. 随机抽取：用Randomize初始化随机数，生成不重复的索引来抽取行，确保不会重复选同一条数据
3. 边界处理：如果某个分组的valid行超过27，会直接保留所有valid行；如果非valid行不够补满27，就取所有非valid行
4. 效率优化：用Union合并需要复制的区域，一次性复制，比逐行复制快很多，适合大数据量

使用注意事项 #

• 把代码里的"源数据"替换成你实际的源工作表名称
• 代码会自动创建「提取结果」工作表，如果已经存在会清空原有数据（保留表头）
• 启用宏之前，确保Excel的宏安全设置允许运行宏
• 如果你的表头不是第一行，记得修改代码里的For i = 2 To lastRow起始数字

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