使用vba根据多个条件随机提取行

Question

我有一个经过审核的文件。我需要根据多个条件提取一些行并将其粘贴到另一张纸上，

excel表A列有审计员姓名，C列有区域，T列有决策（T列有多个值，如有效、无效等，可使用下拉菜单选择。）

我需要一个 VBA 代码，它应该为每个人的每个区域（每个人在多个区域工作）提取 27 行，其中必须包含所有有效的决策，并且可以从剩余的决策中随机选择剩余的行。

最后，如果一个人 A 在 2 个地区工作，uUS 和 UK，最终输出必须有 27 行用于 A 人的 Us，27 行用于 A 人的 UK，同样每个人的行。

Answer 1

使用字典和集合来保存每个人/地区组合的行号。随机选择并从集合中删除所需的样本。

Option Explicit

Sub SampleData()

    Const SAMPLE_SIZE  27
    Const SEP = "~" ' key separator
    
    Dim wb As Workbook, ws As Worksheet, wsOut As Worksheet
    Dim Lastrow As Long, r As Long, rOut As Long
    
    Dim dict As Object, key, ar, k As String, msg As String
    Set dict = CreateObject("Scripting.Dictionary")
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1) ' input data
    
    ' fill dictionary
    With ws
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To Lastrow
            k = Trim(.Cells(r, "A")) & SEP & Trim(.Cells(r, "C")) ' name~region
            If Not dict.exists(k) Then
                dict.Add k, Array(New Collection, New Collection) ' valid, non-valid
            End If
             ' valid or not
            If LCase(Trim(.Cells(r, "T"))) = "valid" Then
                dict(k)(0).Add r
            Else
                dict(k)(1).Add r
            End If
        Next
    End With
    
    ' output results for each person/area
    Dim n As Long, i As Long, x As Long, y As Long
    Dim col As Collection, m As Integer
    
    Application.ScreenUpdating = False
    Set wsOut = wb.Sheets(2)
    With wsOut
        .Cells.Clear
        ws.Rows(1).Copy wsOut.Range("A1")
        rOut = 1
        For Each key In dict.keys
            n = 0
            
            ' do valid then others
            For m = 0 To 1
                Set col = dict(key)(m)
                y = col.Count
                
                ' select valid
                Do While n < SAMPLE_SIZE And y >= 1
                    x = Int(Rnd() * y) + 1 ' random selection
                    r = col.Item(x)
                    rOut = rOut + 1
                    wsOut.Range("A" & rOut & ":T" & rOut).Value2 = ws.Range("A" & r & ":T" & r).Value2
                    col.Remove x ' remove from collection
                    y = col.Count
                    n = n + 1
                Loop
        
            Next
            ' check enough found
            If n < SAMPLE_SIZE Then
                msg = msg & vbLf & n & " for " & key
            End If
        Next
    End With
    Application.ScreenUpdating = True
    
    If msg = "" Then
        MsgBox "Finished", vbInformation
    Else
        MsgBox msg, vbCritical, "Samples short of " & SAMPLE_SIZE
    End If

End Sub