英文:
Finding overlapping employees in departments using excel
问题
我有我的参考数据,看起来像这样。
我试图创建一个日历,使用工作日和5个时间段,如下所示。
使用这个日历,我想要确定部门之间是否存在潜在的冲突。
我的意思是:
- 在任何特定的一天,如果员工在该部门工作(不管时间段),他们只能进入一次。
- 如果有两个部门在特定的一天工作,那么会返回一个错误消息,比如“税务与法务冲突”。
正如你从参考数据中看到的,员工在多个领域工作,我试图尽量减少部门之间的重叠/冲突。
期望的结果看起来像这样:
任何帮助/指导都将不胜感激!
英文:
I have my reference data which looks like this.
I'm trying to create a calendar using weekdays and 5 time slots as shown below.
Using the calendar, I want to identify if there are any potential clashes between departments.
What I mean by that is:
- On any particular day, an employee must only come in once if they work in the department (regardless of the time slot)
- 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:
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.
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论