Randomly Assign Employees to Tasks

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

Answer 1

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 2

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 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