Макрос для выделения x строк данных x количеству людей, а затем цветовой код

Это интересный проект. Код ниже даст вам (в основном) то, что вы ищете. Проблема с форматированием заключается в том, что, хотя можно генерировать случайные форматы, вы можете получить (например) зеленый на зеленом, что непригодно для использования. Таким образом, код копирует любые форматы, которые вы установили для имени каждого человека в столбце E, во все соответствующие ячейки в столбце C.

Я протестировал следующий код с 10 000 записей и 17 людьми, каждый из которых использовал разные форматы. Он пробежал менее чем за 1 секунду. Дайте мне знать, как вы с этим справляетесь.

Option Explicit
Sub AssignTasks()
Dim Records As Long, PasteTo As Long, People As Integer, LastP As Long
Dim balance As Integer, base As Integer, hard As Integer, p As Range
Dim AllRng As Range, BaseStart As Integer
Application.ScreenUpdating = False
 
People = Cells(Rows.Count, 3).End(xlUp).Row
If People <> 1 Then
    ActiveSheet.Range("C2:C" & People).Clear
End If

People = Cells(Rows.Count, 5).End(xlUp).Row
On Error Resume Next
ActiveSheet.Range("E2:E" & People).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0

Records = Cells(Rows.Count, 2).End(xlUp).Row - 1
People = Cells(Rows.Count, 5).End(xlUp).Row - 1

base = Application.WorksheetFunction.RoundDown(Records / People, 0)
balance = Records - (People * base)
hard = base + 1

ActiveSheet.Range("E2:E" & balance + 1).Name = "hardrng"
ActiveSheet.Range("E" & balance + 2 & ":E" & People + 1).Name = "easyrng"

If balance = 0 Then GoTo SkipHard

For Each p In ActiveSheet.Range("hardrng")    
    PasteTo = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Set AllRng = ActiveSheet.Range("C" & PasteTo)
    AllRng.Resize(hard, 1).Value = p.Value    
Next p

SkipHard:
For Each p In ActiveSheet.Range("easyrng")    
    PasteTo = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Set AllRng = ActiveSheet.Range("C" & PasteTo)
    AllRng.Resize(hard - 1, 1).Value = p.Value    
Next p

'Copy the formats
People = Cells(Rows.Count, 5).End(xlUp).Row
LastP = Cells(Rows.Count, 3).End(xlUp).Row

For Each p In ActiveSheet.Range("E2:E" & People)        
    Sheet1.Range("C:C").AutoFilter Field:=1, Criteria1: = "" & p
    p.Copy
    On Error Resume Next
        Sheet1.Range("C2:C" & LastP).SpecialCells(xlCellTypeVisible).PasteSpecial xlFormats            
    On Error GoTo 0
    Application.CutCopyMode = False    
Next p

Sheet1.AutoFilterMode = False    
Application.ScreenUpdating = True
End Sub

Обратите внимание, что вы говорите, что записи находятся в столбце A, но ваше изображение показывает их в столбце B. В этом коде используется столбец B — его легко изменить.