Finding overlapping employees in departments using excel

Alright I think I understand what OP wants and here is my probably entirely unnecessarily complicated VBA solution:

First, setup:

Sheet "calendar", range A1:E6 looks like this:

Sheet "empl", range A1:F10 looks like this:

Code in a "normal" VBA module:

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

And finally, this has to be put in a CLASS module named "Employee":

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

This is what the "Calendar" range looks like after running the "clashOfJobs" sub:

*to have the code run automatically every time you change the calendar, you can add the following code into the SHEET module of the worksheet where your calendar is. You will have to modify the range again, same as with the code above.

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

I also added another sub "showOptions", how to use:
select a cell in the calendar that you want to fill and run the macro. A messagebox will pop up, showing you all the possible departments for that slot and what departments that are already in the calendar they clash with.