Это интересно!
Вот мое решение. Я перепробовал несколько возможных версий.
Попытка 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
Примечание
1. Я не рандомизировал список свободных людей, поэтому их берут по одному. Если вам это нужно - вы можете легко найти макрос для рандомизации массива и вставить его в качестве побочной функции.
2. Я не уверен, что он работает отлично - комментарии приветствуются!
Обновление
Я проспал этот вопрос и решил завершить свой ответ такой важной вещью, как сохранение журнала переназначения в текстовый файл, чтобы код обновлялся.