找到在 Excel 中部门中重叠的员工。

huangapple go评论78阅读模式
英文:

Finding overlapping employees in departments using excel

问题

我有我的参考数据,看起来像这样。

找到在 Excel 中部门中重叠的员工。

我试图创建一个日历,使用工作日和5个时间段,如下所示。

找到在 Excel 中部门中重叠的员工。

使用这个日历,我想要确定部门之间是否存在潜在的冲突。

我的意思是:

  1. 在任何特定的一天,如果员工在该部门工作(不管时间段),他们只能进入一次。
  2. 如果有两个部门在特定的一天工作,那么会返回一个错误消息,比如“税务与法务冲突”。

正如你从参考数据中看到的,员工在多个领域工作,我试图尽量减少部门之间的重叠/冲突。

期望的结果看起来像这样:

找到在 Excel 中部门中重叠的员工。

任何帮助/指导都将不胜感激!

英文:

I have my reference data which looks like this.

找到在 Excel 中部门中重叠的员工。

I'm trying to create a calendar using weekdays and 5 time slots as shown below.

找到在 Excel 中部门中重叠的员工。

Using the calendar, I want to identify if there are any potential clashes between departments.

What I mean by that is:

  1. On any particular day, an employee must only come in once if they work in the department (regardless of the time slot)
  2. If there are two two departments working in a particular day, then an error message such as "Tax clashes with Legal" is returned.

As you can see from the reference data, employees work in multiple fields and I'm trying to minimise the amount of overlaps/clashes between the departments.

Desired results would look something like this:

找到在 Excel 中部门中重叠的员工。

Any help/guidance is appreciated!

答案1

得分: 1

Const calendarSheet As String = "calendar"
Const calendarRange As String = "A2:E6"
Const employeeSheet As String = "empl"
Const employeeRange As String = "A2:F10"

Sub clashOfJobs()
    ' ... (省略部分)
End Sub

Function employeeCol(ByVal arr As Variant) As Collection
    ' ... (省略部分)
End Function

Function uniqueDepts(ByVal arr As Variant) As Collection
    ' ... (省略部分)
End Function

Function clashes(ByVal employees As Collection, depts As Collection) As String
    ' ... (省略部分)
End Function

Sub showOptions()
    ' ... (省略部分)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' ... (省略部分)
End Sub
英文:

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:

Monday Tuesday Wednesday Thursday Friday
Tax Media Cyber
Legal Cyber Policy
Policy IT
Legal

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

ployee ID Job 1 Job 2 Job 3 Job 4 Job 5
65465489 Tax Legal Cyber
46456464 IT Policy
56489789 IT Legal
64849489 IT International
55544664 Tax Media
19498794 IT Legal
21649849 Media Legal International
48855564 Tax Tax
654658246 Cyber Policy

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:

Monday Tuesday Wednesday Thursday Friday
Tax Media Cyber
Legal clashes with Tax Cyber Policy clashes with Cyber
Policy IT clashes with Policy
Legal clashes with Cyber, IT

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

huangapple
  • 本文由 发表于 2023年2月18日 09:25:04
  • 转载请务必保留本文链接:https://go.coder-hub.com/75490606.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定