Randomly Assign Employees to Tasks - vba

Question

This is a follow-up to a previous question that I had. I was provided an answer, but due to my own inexperience and inability, I can't seem to implement it properly.
My situation is as follows:
I need to assign a list of employees to tasks.
There will always be MORE tasks than employees.
Each employee must be assigned to at least ONE
No employee should be assigned to more than two
I need the employee list to randomize during the sorting process so the same employees don't get the same tasks over and over
Where I am coming up short is finding a way that starts "assigning" employees, keeps track of how many times the array(i) employee has been assigned, and if it's greater than two, move onto the next.
An awesome user tried helping me here: Excel VBA to assign employees to tasks using loops
Here is the "test" table I am working with:
Here is the macro I have written to sort my list of employees, which works:
Sub ShuffleEmp()
' This macro's intention is to shuffle the current liste of process assessors
Application.ScreenUpdating = False
Dim tempString As String, tempInteger As Integer, i As Integer, j As Integer, lastRow As Integer
' this grabs the last row with data, so that it can be dynamic
With Sheets("Test")
lastRow = .Range("M" & .Rows.Count).End(xlUp).Row
End With
' this assumes ALWAYS 45 tasks
' starting row 6, going until row 35
For i = 6 To lastRow
' row 6, column 14 (next to Emp column) to start....
Cells(i, 14).Value = WorksheetFunction.RandBetween(0, 1000)
Next i
'now it has assigned random values...
For i = 6 To lastRow
For j = i + 1 To lastRow
'14 is the number column...
If Cells(j, 14).Value < Cells(i, 14).Value Then
'change the string, which is the Emp column...
tempString = Cells(i, 13).Value
Cells(i, 13).Value = Cells(j, 13).Value
Cells(j, 13).Value = tempString
tempInteger = Cells(i, 14).Value
Cells(i, 14).Value = Cells(j, 14).Value
Cells(j, 14).Value = tempInteger
End If
Next j
Next i
Worksheets("Test").Range("N:N").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Here is the macro for turning that list into an array:
Sub EmpArray()
' This stores the column of Emps as an array
Dim Storage() As String ' initial storage array to take values
Dim i As Long
Dim j As Long
Dim lrow As Long
lrow = Cells(Rows.Count, "M").End(xlUp).Row ' The amount of stuff in the column
ReDim Storage(1 To lrow - 5)
For i = lrow To 6 Step -1
If (Not IsEmpty(Cells(i, 13).Value)) Then ' checks to make sure the value isn't empty
j = j + 1
Storage(j) = Cells(i, 13).Value
End If
Next i
ReDim Preserve Storage(1 To j)
For j = LBound(Storage) To UBound(Storage) ' loop through the previous array
MsgBox (Storage(j))
Next j
End Sub

Answer 1

This is your entire program here. It's tested and works. The only problem is that your screenshot didn't show the row and column headers, so I had to assume that Task was column B, row 1.
Here is your main Subroutine. This is the program that you will assign your button to. This will automatically check to see if your employeeList is uninitialized (basically empty) and rebuild it using the function buildOneDimArr.
Sub assignEmployeeTasks()
Dim ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets(1)
Dim employeeList() As Variant
With ws
For i = 2 To lastRow(ws, 2)
If (Not employeeList) = -1 Then
'rebuild employeelist / array uninitialized
employeeList = buildOneDimArr(ws, "F", 2, lastRow(ws, "F"))
End If
.Cells(i, 4) = randomEmployee(employeeList)
Next
End With
End Sub
These are the "support" functions that allow your program to do it's job:
Function randomEmployee(ByRef employeeList As Variant) As String
'Random # that will determine the employee chosen
Dim Lotto As Long
Lotto = randomNumber(LBound(employeeList), UBound(employeeList))
randomEmployee = employeeList(Lotto)
'Remove the employee from the original array before returning it to the sub
Dim retArr() As Variant, i&, x&, numRem&
numRem = UBound(employeeList) - 1
If numRem = -1 Then 'array is empty
Erase employeeList
Exit Function
End If
ReDim retArr(numRem)
For i = 0 To UBound(employeeList)
If i <> Lotto Then
retArr(x) = employeeList(i)
x = x + 1
End If
Next i
Erase employeeList
employeeList = retArr
End Function
' This will take your column of employees and place them in a 1-D array
Function buildOneDimArr(ByVal ws As Worksheet, ByVal Col As Variant, _
ByVal rowStart As Long, ByVal rowEnd As Long) As Variant()
Dim numElements As Long, i As Long, x As Long, retArr()
numElements = rowEnd - rowStart
ReDim retArr(numElements)
For i = rowStart To rowEnd
retArr(x) = ws.Cells(i, Col)
x = x + 1
Next i
buildOneDimArr = retArr
End Function
' This outputs a random number so you can randomly assign your employee
Function randomNumber(ByVal lngMin&, ByVal lngMax&) As Long
'Courtesy of https://stackoverflow.com/a/22628599/5781745
Randomize
randomNumber = Int((lngMax - lngMin + 1) * Rnd + lngMin)
End Function
' This gets the last row of any column you specify in the arguments
Function lastRow(ws As Worksheet, Col As Variant) As Long
lastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
End Function
You are going to want to place all of these into a standard module.

Answer 2

I created a solution for you which might help you to develop further also in general understanding of programming.
With my solution you dont need to shuffle your employees beforehand and you will use some stuff you might have not used before.
First of all I created a new Class Module called Employee which looks like this:
Private p_name As String
Private p_task As String
Public Property Get Name() As String
Name = p_name
End Property
Public Property Let Name(ByVal value As String)
p_name = value
End Property
Public Property Get Task() As String
Task = p_task
End Property
Public Property Let Task(ByVal value As String)
p_task = value
End Property
This is only a small class to hold an employeename and a task.
In a normal Module I added a method called ShuffleTasks with 2 collections as parameters. A Collection is a slightly more comfortable and therefor slightly heavier and slower version of an array.
Private Sub ShuffleTasks(t As Collection, emp As Collection)
Dim i As Integer
Dim count As Integer
Dim employ As employee
count = emp.count
Dim remIndex As Integer
For i = 1 To count
'randomize
Randomize
'get a random index from tasks by its count
remIndex = Int((t.count) * Rnd + 1)
'add the task to the employee list
emp.Item(i).Task = t.Item(remIndex)
'remove the task so it wont be assigned again
t.Remove (remIndex)
Next
End Sub
The first parameter is a collection of the tasks(which is just a string with the name), the second the collection of the employees. The second one will also the one being used as the result.
Then I iterate through all employees and generate a random integer between 1 and the count of the tasks. I'll add the task to the current employee in the collection and REMOVE it from the tasklist. In the next iteration the numbers of tasks will be -1 and again randomized chosen from the amount of items in the collection.
Then I modified your EmpArray Method to fill some data from a sheet and call the ShuffleTasks method
Sub EmpArray()
' This stores the column of Emps as an Collection
Dim sEmployees As New Collection, sTasks As New Collection ' initial storage array to take values
Dim i As Long
Dim j As Long
Dim s As Variant
Dim lrow As Long
Dim emp As employee
lrow = Cells(Rows.count, "M").End(xlUp).Row ' The amount of stuff in the column
For i = lrow To 6 Step -1
If (Not IsEmpty(Cells(i, 13).value)) Then ' checks to make sure the value isn't empty
j = j + 1
'Storage(j) = Cells(i, 13).Value
Set emp = New employee
emp.Name = Cells(i, 13).value
sEmployees.Add emp
End If
Next i
' This stores the column of Tasks as an Collection
' I assume it is column 9
lrow = Cells(Rows.count, "I").End(xlUp).Row ' The amount of stuff in the column
For i = lrow To 6 Step -1
If (Not IsEmpty(Cells(i, 9).value)) Then ' checks to make sure the value isn't empty
j = j + 1
sTasks.Add Cells(i, 9).value
End If
Next i
ShuffleTasks sTasks, sEmployees
For Each emp In sEmployees
Debug.Print (emp.Name & ": " & emp.Task)
Next
End Sub
As you can see the modifications on the Collection will show you each time a new employee name and task. Keep in mind that it is ofc not true random. Also the collection of tasks will have less items after the method ShuffleTasks. I just wanted to show you an approach which is basically working a bit with data in vba. You only load data from the sheet, then manipulate that in pure vba objects. The results can also be written back to the sheet, I just print them to Debug Window in your vba editor.
Hope this helps. It is for sure a quick and dirty solution and I also didnt cover all aspects of Collections and also Parameters and ByVal vs ByRef etc. But maybe this will inspire you a bit ;)

Answer 3

I hope I understood it correctly:
Sub AssignEmpl()
Dim TaskTable As Range, EmpTable As Range
Dim lRowT As Long, lRowE As Long, iCell As Range
lRowT = Worksheets("Test").Range("I" & Worksheets("Test").Rows.Count).End(xlUp).Row
lRowE = Worksheets("Test").Range("M" & Worksheets("Test").Rows.Count).End(xlUp).Row
' Don't know what are actual ranges, modify
Set TaskTable = Worksheets("Test").Range("I6:K" & lRowT)
Set EmpTable = Worksheets("Test").Range("M6:M" & lRowE)
' Starting loop
Do
' Populate column with random nubmers between 1 and number of employees
' 5 is a number of employees (essentialy lRowE - 5 or something like that)
TaskTable.Columns(3).Formula = "=RANDBETWEEN(1," & lRowE - 5 & ")"
' Remove formula (so it doesn't recalculate)
TaskTable.Columns(3).Value = TaskTable.Columns(3).Value
' Check if any number appears more than 2 times
Loop While Evaluate("AND(MAX(COUNTIF(" & TaskTable.Columns(3).Address & "," & TaskTable.Columns(3).Address & "))>2)")
' Put these employee in there
For Each iCell In TaskTable.Columns(3).Cells
iCell.Value = EmpTable.Cells(iCell.Value, 1)
Next
End Sub