Test for Overlapping Project Assignment

[arns]

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?

[snb]

I'd prefer preventing any errors.

[arns]

Exactly what I meant to say, thank you :)

[Paul_Hossler]

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

[arns]

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]

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

[arns]

Dear Paul.

This is excellent and thank you again for your quick response to my problem.

arns

[Paul_Hossler]

It was fun

You can mark your post as [Solved] -- #3 in my sig