VBA按审计员+区域抽取27行数据（优先含Valid）的实现求助

修改后可实现需求的VBA代码 #

Option Explicit
Public gcolNames As Collection
Public Const kiPULLQTY = 27 ' 每个分组抽取总数量，可按需调整
Public Const kiColAUDITOR = 1 ' A列存审计员
Public Const kiColREG = 3 ' C列存区域
Public Const kiColRESULT = 24 ' X列存审核结论
Public giMarker As Long ' 输出表的写入行标记

Public Sub RunData()
    Dim wsVerify As Worksheet
    ' 新建/清空结果表Verification
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Verification").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set wsVerify = Sheets.Add
    wsVerify.Name = "Verification"
    ' 复制表头到结果表
    Sheets("Audit file").Rows(1).Copy wsVerify.Rows(1)
    giMarker = 2 ' 从第二行开始写数据
    
    AuditList ' 生成审计员去重列表
    LoadNames ' 加载审计员到集合
    MakeResults ' 按规则抽取数据
    MsgBox "数据抽取完成，结果已保存到Verification工作表", vbInformation
End Sub

Private Sub AuditList()
    Dim iRows As Long
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Auditors").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Sheets.Add
    ActiveSheet.Name = "auditors"
   
    Sheets("Audit file").Select
    Columns("A:A").Copy
    Sheets("auditors").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
   
    iRows = ActiveSheet.UsedRange.Rows.Count
    ActiveSheet.Range("$A$1:$A$" & iRows).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

' 加载审计员列表到集合
Private Sub LoadNames()
    Dim sName As String
    Set gcolNames = New Collection
   
    Sheets("auditors").Select
    Range("A2").Select
    While ActiveCell.Value <> ""
       sName = ActiveCell.Value
       gcolNames.Add sName, sName
       ActiveCell.Offset(1, 0).Select
    Wend
    Sheets("Audit file").Select
End Sub

Private Sub MakeResults()
    Dim i As Integer
    Dim vName, regName
    Dim colRegions As Collection
    Dim wsAudit As Worksheet, wsVerify As Worksheet
    Dim rngData As Range, rngValid As Range, rngNonValid As Range
    Dim lValidCnt As Long, lNeed As Long, lRow As Long
    Dim arrNonValid, arrRand, iRand As Long, j As Long
    
    Set wsAudit = Sheets("Audit file")
    Set wsVerify = Sheets("Verification")
    Set rngData = wsAudit.UsedRange
    
    ' 遍历每个审计员
    For i = 1 To gcolNames.Count
        vName = gcolNames(i)
        ' 获取当前审计员对应的所有唯一区域
        Set colRegions = New Collection
        On Error Resume Next
        For lRow = 2 To rngData.Rows.Count
            If rngData.Cells(lRow, kiColAUDITOR) = vName Then
                regName = rngData.Cells(lRow, kiColREG)
                colRegions.Add regName, CStr(regName)
            End If
        Next
        On Error GoTo 0
        
        ' 遍历当前审计员的每个区域
        For Each regName In colRegions
            ' 筛选当前审计员+当前区域下的Valid行
            rngData.AutoFilter Field:=kiColAUDITOR, Criteria1:=vName
            rngData.AutoFilter Field:=kiColREG, Criteria1:=regName
            rngData.AutoFilter Field:=kiColRESULT, Criteria1:="Valid"
            
            ' 复制Valid行到结果表
            On Error Resume Next
            Set rngValid = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            lValidCnt = 0
            If Not rngValid Is Nothing Then
                lValidCnt = rngValid.Areas(1).Rows.Count
                rngValid.Copy wsVerify.Cells(giMarker, 1)
                giMarker = giMarker + lValidCnt
            End If
            
            ' 计算需要补充的数量
            lNeed = kiPULLQTY - lValidCnt
            If lNeed > 0 Then
                ' 取消X列筛选，显示非Valid行
                rngData.AutoFilter Field:=kiColRESULT
                On Error Resume Next
                Set rngNonValid = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rngNonValid Is Nothing Then
                    ' 非Valid行数量不足时取全部
                    If rngNonValid.Rows.Count < lNeed Then lNeed = rngNonValid.Rows.Count
                    ' 生成随机不重复索引抽取
                    ReDim arrNonValid(1 To rngNonValid.Rows.Count)
                    For j = 1 To UBound(arrNonValid)
                        arrNonValid(j) = j
                    Next
                    ' 打乱数组
                    Randomize
                    For j = UBound(arrNonValid) To LBound(arrNonValid) Step -1
                        iRand = Int((j - LBound(arrNonValid) + 1) * Rnd + LBound(arrNonValid))
                        Dim temp: temp = arrNonValid(j): arrNonValid(j) = arrNonValid(iRand): arrNonValid(iRand) = temp
                    Next
                    ' 复制抽取的行
                    For j = 1 To lNeed
                        rngNonValid.Areas(1).Rows(arrNonValid(j)).Copy wsVerify.Cells(giMarker, 1)
                        giMarker = giMarker + 1
                    Next
                End If
            End If
            ' 清除筛选，处理下一个分组
            wsAudit.ShowAllData
        Next
    Next
    ' 关闭筛选
    If wsAudit.AutoFilterMode Then wsAudit.AutoFilterMode = False
    ' 删除临时Auditors表
    Application.DisplayAlerts = False
    Sheets("Auditors").Delete
    Application.DisplayAlerts = True
End Sub

核心修改说明 #

• 适配实际表结构：数据源表改为Audit file，统一输出结果到Verification表，自动匹配A/C/X列的字段规则
• 新增二级分组逻辑：按「审计员+区域」为单个处理单元，每个单元独立执行抽取规则
• 严格匹配抽取规则：每个分组优先提取所有Valid的行，不足27行的部分从同分组非Valid行中随机抽取补齐，若非Valid行也不足则全部提取
• 自动清理临时文件：运行完成后自动删除中间生成的Auditors临时表，无需手动清理
• 保留可调整入口：如需修改每个分组的抽取数量，直接修改常量kiPULLQTY的取值即可

使用注意 #

运行宏前请确认Audit file工作表是当前工作簿的活跃数据源表，表头在第一行、数据从第二行开始即可。

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