Const calendarSheet As String = "calendar"
Const calendarRange As String = "A2:E6"
Const employeeSheet As String = "empl"
Const employeeRange As String = "A2:F10"
Sub clashOfJobs()
    Dim employeeArr() As Variant, rng As Range, calendar As Variant
    
    Set rng = Worksheets(employeeSheet).Range(employeeRange)
    
    employeeArr = rng
    
    Set rng = Worksheets(calendarSheet).Range(calendarRange)
    
    calendar = rng
    
    Dim employees As Collection
    Set employees = employeeCol(employeeArr)
    
    Dim departments As Collection, dept As String
    
    For j = 1 To UBound(calendar, 2)
        Set departments = New Collection
        For i = 1 To UBound(calendar)
            dept = calendar(i, j)
            If dept <> "" Then
                departments.Add dept
                calendar(i, j) = clashes(employees, departments)
                'Debug.Print clashes(employees, departments)
            End If
        Next i
        
    Next j
    rng = calendar
End Sub
Function employeeCol(ByVal arr As Variant) As Collection
    Set employeeCol = New Collection
    Dim empl As Employee
    For i = 1 To UBound(arr)
        Set empl = New Employee
        empl.id = arr(i, 1)
        If empl.id <> 0 Then
            For j = 2 To UBound(arr, 2)
                empl.addJob arr(i, j)
            Next j
            employeeCol.Add empl
        End If
    Next i
End Function
Function uniqueDepts(ByVal arr As Variant) As Collection
    Set uniqueDepts = New Collection
    For i = 1 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            On Error Resume Next
                If arr(i, j) <> "" Then uniqueDepts.Add arr(i, j), arr(i, j)
            On Error GoTo 0
        Next j
    Next i
End Function
Function clashes(ByVal employees As Collection, depts As Collection) As String
    Dim separator As String
    separator = ", "
    
    Dim emp As Employee, dept As String, job As String, lastDept As String
    
    lastDept = depts(depts.Count)
    
    If depts.Count = 1 Then
        clashes = lastDept
        Exit Function
    End If
    
    Dim clashCounter As Integer
    
    For i = 1 To depts.Count - 1
        dept = depts(i)
        clashCounter = 0
        For Each emp In employees
            If emp.hasJob(dept) And emp.hasJob(lastDept) Then
                If clashCounter = 0 Then
                    clashes = clashes & dept
                End If
                clashCounter = clashCounter + 1
            End If
        Next emp
        If clashCounter > 0 Then
            clashes = clashes & "(" & clashCounter & ")" & separator
        End If
    Next i
    If clashes <> vbNullString Then
        clashes = lastDept & " clashes with " & clashes
        clashes = Left(clashes, Len(clashes) - Len(separator))
        Else
            clashes = lastDept
        End If
End Function
Sub showOptions()
    Dim employeeArr() As Variant, rng As Range, calendar As Variant
    
    Set rng = Worksheets(employeeSheet).Range(employeeRange)
    
    employeeArr = rng
    
    Set rng = Worksheets(calendarSheet).Range(calendarRange)
    
    If Application.Intersect(Selection, rng) Is Nothing Then
        MsgBox "Please select a calendar cell"
        Exit Sub
    End If
    
    calendar = rng
    
    Dim employees As Collection, uniqueDepartments As Collection
    Set employees = employeeCol(employeeArr)
    Set uniqueDepartments = uniqueDepts(employeeArr)
    
    Dim calRow As Integer, calCol As Integer
    calRow = Selection.Row - rng.Row + 1
    calCol = Selection.Column - rng.Column + 1
    
    Dim departments As Collection, cdpt As String
    Set departments = New Collection
    For i = 1 To calRow - 1
        cdpt = calendar(i, calCol)
        If cdpt = "" Then
            MsgBox "There are empty cells above your selection, select different cell"
            Exit Sub
        End If
        departments.Add cdpt, cdpt
    Next i
    
    Dim clashesStr As String
    For Each dept In uniqueDepartments
        On Error GoTo skip
            departments.Add dept, dept
            clashesStr = clashesStr & clashes(employees, departments) & vbCrLf
            departments.Remove departments.Count
skip:
            On Error GoTo -1
    Next dept
    
    MsgBox clashesStr
    
End Sub

Private f_jobs As Collection
Private f_id As Long
Private Sub Class_Initialize()
    Set f_jobs = New Collection
End Sub
Public Sub addJob(ByVal job As String)
    On Error Resume Next
    If job <> "" Then jobs.Add job, job
    On Error GoTo 0
End Sub
Property Get jobs() As Collection
    Set jobs = f_jobs
End Property
Property Get id() As Long
    id = f_id
End Property
Property Let id(ByVal id As Long)
    f_id = id
End Property
Public Function hasJob(ByVal job As String) As Boolean
    hasJob = False
    For Each j In f_jobs
        If j = job Then
            hasJob = True
            Exit For
        End If
    Next j
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Application.Intersect(Worksheets("calendar").Range("A2:E6"), Target) Is Nothing Then
        clashOfJobs
    End If
    Application.EnableEvents = True
End Sub