Excel筛选表数据以满足采样要求

Question

我需要在可用于采样的数据表中为每个投诉处理者获得2个随机案例。

假设我将不得不使用处理程序ID（每个投诉处理程序的唯一引用）将数据分组，然后再从中选择一些随机的信息。

我已使用数据透视表对这些信息进行了分组。此案例中的所有案例处理程序都具有2个或更少的案例，因此无需对此采取进一步的措施。但是，克里斯·史密斯（h238）有一个例外，他有3个案例，每个案例处理程序的最大抽样为2个。

我需要一个脚本，该脚本将为Chris选择两个随机案例并删除所有其他案例（因此我们有2个案例的随机样本）。

我可以手动执行此操作，方法是按Chris的案例过滤表，然后删除案例，直到仅剩两个案例为止。但是，实际数据集会大得多，因此非常耗时，并且该过程每天需要运行几次，并且表中的数据会不断变化。

Answer 1

那很有趣！

这是我的解决方案。我尝试了几种可能的版本。
尝试1：
根据最初发布的数据-克里斯·史密斯（h238）超载了1个任务，并且有足够的人来重新分配任务： 试试2：
克里斯·史密斯（克里斯·史密斯（h238））仍然超负荷工作，但这一次有3个任务，并且有足够的人来重新分配任务： 试试3：
可怜的克里斯·史密斯（h238）完全不堪重负，但是这次没有足够的人来重新分配任务： 试试4： 这次，简·多伊（h324）与克里斯·史密斯（h238）保持一致-他们超负荷工作，但是没有足够的人来重新分配任务：

在没有超载或没有空闲人员破坏适当消息的情况下，没有进行屏幕截图。
代码：

Sub ReassignCases()
' Variables
' people  related:
Dim handlerIdRange As Range, handlerId As Range
Dim maxCases As Long
Dim cases As Long
Dim name As String, id As String
Dim nameTo As String, idTo As String
Dim caseRef As Range

' arrays:
Dim overloaded() As String
Dim free() As String

' counters:
Dim o As Long, f As Long, i As Long, c As Long, j As Long

' unique values container
Dim handlersList As New Collection

' output
Dim msg As String

Dim workSht As Worksheet

'----------------------------------------------------
' reassign the sheet name as you have in your workbook
Set workSht = ThisWorkbook.Sheets("Sheet1")

' parameter that can be changed if needed
maxCases = 2

With workSht
    Set handlerIdRange = Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp))
End With

' get the list of handlers
On Error Resume Next
For Each handlerId In handlerIdRange
    handlersList.Add handlerId & ";" & handlerId.Offset(0, -1), handlerId & ";" & handlerId.Offset(0, -1)
Next
Err.Clear
On Error GoTo 0

For i = 1 To handlersList.Count

    ' look for overloaded
    If Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0)) > maxCases Then
        ReDim Preserve overloaded(o)
        ' adding to array: id;name;qty of cases
        overloaded(o) = handlersList.Item(i) & ";" & Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0))
        o = o + 1
    ' look for those who has less the 2 cases. If one has 2 cases - he is not free
    ElseIf Application.WorksheetFunction.CountIf(handlerIdRange, Split(handlersList(i), ";")(0)) < maxCases Then
        ReDim Preserve free(f)
        free(f) = handlersList.Item(i)
        f = f + 1
    End If
Next

' check whether there are overloaded handlers
If Not Not overloaded Then
    ' if yes - proceed further
    Else
    ' if not - inform and quit
    MsgBox "There are no overloaded handlers.", vbInformation, "Info"
    Exit Sub
End If

' check whether there are free handlers
If Not Not free Then
    ' if yes - proceed further
    Else
    ' if not - inform and quit
    o = UBound(overloaded) + 1
    MsgBox "There " & IIf(o = 1, "is ", "are ") & o & " overloaded " & IIf(o = 1, "handler", "handlers") & ", but 0 free.", vbInformation, "Info"
    Exit Sub
End If
msg = ""
' go through array of overloaded
For i = LBound(overloaded) To UBound(overloaded)
    ' Id of overloaded
    id = Split(overloaded(i), ";")(0)
    ' Name of overloaded
    name = Split(overloaded(i), ";")(1)
    ' number of over cases = total assigned - 2 (max cases)
    cases = Split(overloaded(i), ";")(2) - maxCases
    '

    ' check that there some free people left
    If Not c > UBound(free) Then
    ' go through each handler in the array of free people
    ' free people are those, who have only 1 task and can take another 1

    ' if c was not used yet it is 0, otherwise, it will continue looping through free people
        For c = c To UBound(free)

            idTo = Split(free(c), ";")(0)
            nameTo = Split(free(c), ";")(1)

            ' find the first match of the id in Id range
            Set caseRef = handlerIdRange.Find(what:=id, LookIn:=xlValues)
            ' give an outcome of what was reassigned
            msg = msg & "Task: " & caseRef.Offset(0, 1).Text & " was reassigned from " & name & " (" & id & ") "
                With caseRef
                    .Value = idTo
                    .Offset(0, -1).Value = nameTo
                End With
            msg = msg & "to " & nameTo & " (" & idTo & ")" & Chr(10)
            cases = cases - 1
            ' when all needed cases are passed to other stop looking through free people
            If cases = 0 Then Exit For
        Next
        ' if the loop through free people is finished,
        ' but there left some more - go to warning creation
        If Not cases = 0 Then GoTo leftCases
    Else
leftCases:
        msg = msg & Chr(10) & Chr(10) & "There are no more free handlers." & Chr(10)

        For j = i To UBound(overloaded)
            msg = msg & Split(overloaded(j), ";")(1) & " is still overloaded with " & cases & " cases." & Chr(10)
        Next

        msg = msg & Chr(10) & "Operation completed with warnings." & Chr(10)
        msg = msg & Chr(10) & "Would you like to save results?"
        If MsgBox(msg, vbExclamation + vbYesNo, "Done") = vbYes Then SaveResults (msg)
        Exit Sub
    End If
Next

msg = msg & Chr(10) & "Operation completed." & Chr(10)

msg = msg & Chr(10) & "Would you like to save results?"

If MsgBox(msg, vbInformation + vbYesNo, "Done") = vbYes Then SaveResults (msg)

End Sub

Sub SaveResults(Text As String)

Dim lines() As String, temp() As String
Dim i As Long, j As Long

Dim FileName As String

lines = Split(Text, Chr(10))

For i = LBound(lines) To UBound(lines)
    If lines(i) Like "Task:*" Then
        ReDim Preserve temp(j)
        temp(j) = lines(i)
        j = j + 1
    End If
Next

Dim fi As Long

FileName = "Task reassignment log"

FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, FileFilter:="Text Files (*.txt), *.txt", Title:="Saving as text...")

If UCase(FileName) = "FALSE" Then Exit Sub

If CheckFileExists(FileName) Then
    If MsgBox("The file " & Dir(FileName) & " already exists. Overwrite?", vbQuestion + vbYesNo) = vbYes Then
        WriteToFile FileName, temp
    Else
        i = 0
        Do Until Not CheckFileExists(FileName)
            For j = Len(FileName) To 1 Step -1
                If Mid(FileName, j, 1) = Application.PathSeparator Then Exit For
            Next

            FileName = Left(FileName, j)
            If i = 0 Then
                FileName = FileName & "Task reassignment log.txt"
            Else
                FileName = FileName & "Task reassignment log (" & i & ")" & ".txt"
            End If
            i = i + 1
        Loop
        WriteToFile FileName, temp
        MsgBox "The file was saved with " & Chr(34) & Dir(FileName) & Chr(34) & " name", vbInformation
    End If
Else
    WriteToFile FileName, temp
End If


End Sub

Sub WriteToFile(FileName As String, Text() As String)
Dim i As Long

Open FileName For Output As #1
    For i = LBound(Text) To UBound(Text)
        Write #1, Text(i)
    Next
Close #1
End Sub

Function CheckFileExists(FileName As String) As Boolean
CheckFileExists = False
If Not Dir(FileName) = "" Then CheckFileExists = True
End Function

注意
我没有随机列出一个免费的人，所以他们是一个接一个的。如果确实需要这样做，则可以轻松地找到一个宏来随机化数组并将其作为辅助函数插入。
2.我不确定它是否完美运行-感谢评论！

更新
我已经解决了这个问题，并决定通过将重分配日志保存到文本文件这样的重要事情来完成我的答案，以便更新代码。