将 x 行数据分配给 x 人数然后颜色代码的宏

Question

I have a task I perform I'm looking to automate for a relatively large set of data. Basically, I have a list of records that I need to assign out to a group of people and then color code those assignments accordingly.

There is no set count of how many records there will be, so the number of rows is a variable. The number of people is also a variable.

The Records are in column A. The People are in Column E.

If there are 1000 records and 20 people, then assign 50 records per person by entering their name in column C.

So how can I create a macro that will:

1- count the Number of Records and divide by the Number of People
2- use that number as the number of records to assign each person and input the person's name in column C
3- assign each person with a different Fill Color and Font Color to help distinguish between one another. (is it possible to assign the same color scheme for each name in column C as well as column E?)

here's a sample of what I'm looking to accomplish

Answer 1

It's an interesting project. The code below will give you (mostly) what you're looking for. The issue with formatting is that, whereas it's possible to generate random formats – you could end up with (eg) green on green which is unusable. The code therefore copies whatever formats you set on each person's name in column E to all of the corresponding cells in column C.

I tested the following code with 10,000 records & 17 people each with different formats. It ran in under 1 second. Let me know how you go with it.

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

Note that you say the records are in column A, but your image shows them in column B. This code uses column B - easily changed.