View Full Version : [SOLVED:] Test for Overlapping Project Assignment
Hi.
I have a table (T_Assignment) where I assign salesmen to various predefined projects within the year.
I would like to have the possibility to assign the same person to more than one project.
No limit on how many persons are assigned to the same project.
Each person can only be assigned to one project at a time.
I need a VBA code to test for Overlapping Project Assignment and preferably highlight the error.
Salesman
...some other columns..
Project no
Start month
End month
John
100
1
8
Paul
200
1
12
Ringo
300
5
11
George
400
2
12
John
200
2
12
Ringo
300
6
8
John
300
10
12
Can anybody please help me?
I'd prefer preventing any errors.
Exactly what I meant to say, thank you :)
Paul_Hossler
10-25-2017, 08:49 AM
One way to do it
20747
Option Explicit
Const colSalesman As Long = 1
Const colStart As Long = 4
Const colEnd As Long = 5
Sub CheckOverlap()
Dim rData As Range, rDataNoHeaders As Range
Dim rowNum As Long, colNum As Long, colMonths As Long, colOverlapStart As Long, colOverlapEnd As Long
'set the data to use
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Application.ScreenUpdating = False
With Worksheets("Sheet1")
'add Month cols
colMonths = rData.Columns.Count + 1
For colNum = 1 To 12
.Cells(1, colMonths + colNum - 1).Value = "Month " & colNum
Next
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Set rDataNoHeaders = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
rDataNoHeaders.Interior.ColorIndex = xlColorIndexNone
'fill in 12 Month col
With rData
For rowNum = 2 To .Rows.Count
For colNum = .Cells(rowNum, colStart).Value To .Cells(rowNum, colEnd).Value
.Cells(rowNum, colMonths + colNum - 1).Interior.Color = vbGreen
Next colNum
Next rowNum
End With
'sort by Saleman and Start
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rDataNoHeaders.Columns(colSalesman), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rDataNoHeaders.Columns(colStart), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'check to see if Nth Salesman = N+1-th Salesman AND Nth End => N+1-th Start
With rData
For rowNum = 2 To .Rows.Count - 1
If .Cells(rowNum, colSalesman).Value = .Cells(rowNum + 1, colSalesman).Value And _
.Cells(rowNum, colEnd).Value >= .Cells(rowNum + 1, colStart).Value Then
colOverlapStart = Application.WorksheetFunction.Max(.Cells(rowNum, colStart).Value, .Cells(rowNum + 1, colStart).Value)
colOverlapEnd = Application.WorksheetFunction.Min(.Cells(rowNum, colEnd).Value, .Cells(rowNum + 1, colEnd).Value)
For colNum = colOverlapStart To colOverlapEnd
.Cells(rowNum, colMonths + colNum - 1).Interior.Color = vbRed
.Cells(rowNum + 1, colMonths + colNum - 1).Interior.Color = vbRed
Next colNum
End If
Next rowNum
End With
'reset sort order - by Start and Saleman
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rDataNoHeaders.Columns(colStart), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rDataNoHeaders.Columns(colSalesman), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.ScreenUpdating = True
End Sub
Hi Paul.
Thank you for your time and reply.
This is in the direction that I was looking for.
For the current code I need to add "Range("F:Q").Delete" at the beginning of the script, to reset the test.
However my data is in a table (Table1) and I would like the month check (i.e. Month 1, Month 2 etc.) to start at the end of the table; hence I can add more columns to the Table, if needed, without affecting the code.
oh, and I forgot to add one extra condition..the column header "End Month" must be equal or larger than column header "Start Month".
Can this code be adapted to use with excel Table?
arns
Paul_Hossler
10-25-2017, 03:13 PM
If it were more complicated, I'd probably use a more robust method, but this seems to work OK -- Elton has end before start and the columns can be in any order
20754
Option Explicit
Sub CheckOverlap()
Dim rData As Range, rDataNoHeaders As Range
Dim rowNum As Long, colNum As Long, colMonths As Long, colOverlapStart As Long, colOverlapEnd As Long
Dim colSalesman As Long, colStart As Long, colEnd As Long
'set the data to use
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Application.ScreenUpdating = False
With Worksheets("Sheet1")
'find Salesman, Start, End columns
colSalesman = Application.WorksheetFunction.Match("Salesman", .Rows(1), 0)
colStart = Application.WorksheetFunction.Match("Start Month", .Rows(1), 0)
colEnd = Application.WorksheetFunction.Match("End Month", .Rows(1), 0)
'see if 'Month 1' is already there
colMonths = 0
On Error Resume Next
colMonths = Application.WorksheetFunction.Match("Month 1", .Rows(1), 0)
On Error GoTo 0
'it is so delete next 12 columns
If colMonths > 0 Then .Columns(colMonths).Resize(, 12).Delete
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
'add Month cols
colMonths = rData.Columns.Count + 1
For colNum = 1 To 12
.Cells(1, colMonths + colNum - 1).Value = "Month " & colNum
Next
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Set rDataNoHeaders = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
rDataNoHeaders.Interior.ColorIndex = xlColorIndexNone
'fill in 12 Month col with GREEN
With rData
For rowNum = 2 To .Rows.Count
For colNum = .Cells(rowNum, colStart).Value To .Cells(rowNum, colEnd).Value
.Cells(rowNum, colMonths + colNum - 1).Interior.Color = vbGreen
Next colNum
Next rowNum
End With
'sort by Saleman and Start
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rDataNoHeaders.Columns(colSalesman), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rDataNoHeaders.Columns(colStart), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'check to see start is NOT <= end
With rData
For rowNum = 2 To .Rows.Count
If .Cells(rowNum, colStart).Value > .Cells(rowNum, colEnd).Value Then
For colNum = .Cells(rowNum, colEnd).Value To .Cells(rowNum, colStart).Value
.Cells(rowNum, colMonths + colNum - 1).Interior.Color = vbBlue
Next colNum
End If
Next rowNum
End With
'check to see if Nth Salesman = N+1-th Salesman AND Nth End > N+1-th Start
With rData
For rowNum = 2 To .Rows.Count - 1
If .Cells(rowNum, colSalesman).Value = .Cells(rowNum + 1, colSalesman).Value And _
.Cells(rowNum, colEnd).Value >= .Cells(rowNum + 1, colStart).Value Then
colOverlapStart = Application.WorksheetFunction.Max(.Cells(rowNum, colStart).Value, .Cells(rowNum + 1, colStart).Value)
colOverlapEnd = Application.WorksheetFunction.Min(.Cells(rowNum, colEnd).Value, .Cells(rowNum + 1, colEnd).Value)
For colNum = colOverlapStart To colOverlapEnd
.Cells(rowNum, colMonths + colNum - 1).Interior.Color = vbRed
.Cells(rowNum + 1, colMonths + colNum - 1).Interior.Color = vbRed
Next colNum
End If
Next rowNum
End With
'reset sort order - by sStart and Saleman
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rDataNoHeaders.Columns(colStart), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rDataNoHeaders.Columns(colSalesman), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.ScreenUpdating = True
End Sub
Dear Paul.
This is excellent and thank you again for your quick response to my problem.
arns
Paul_Hossler
10-26-2017, 05:35 AM
It was fun
You can mark your post as [Solved] -- #3 in my sig
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.