VBA Code to highlight scheduling errors

[markster]

Right I’m onto the second stage of my big scheduling job.

When scheduling takes place there is always errors the most common things are:

A teacher might be booked to teach to different courses at exactly the same time in different places – this is a clash

The same room might be double booked by different teachers for teaching at exactly the same time – this is a clash

-Missing information or TBC written in a cell

I need some Macro code to highlight any rows in yellow that contain a clash or missing information. Here are some examples:

20210923 - Data Download from Timetabling System.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	Reference	Course Name	Room Number	Location	Allocated Teacher	Delivery Dates	Scheduled Days	Planned Size	Size	Scheduled Start Time	Scheduled End Time	Duration
2	1	Course 1	23	London	Teacher 1	28/9/2021	Tuesday	0	0	09:00	10:00	01:00
3	2	Course 1	23	London	Teacher 1	26/10/2021	Tuesday	0	0	09:00	10:00	01:00
4	3	Course 1	23	London	Teacher 1	16/11/2021	Tuesday	0	0	09:00	10:00	01:00
5	4	Course 1	23	London	Teacher 1	23/11/2021	Tuesday	0	0	09:00	10:00	01:00
6	5	Course 2	24	London	Teacher 2	28-Sep-21	Tuesday	0	0	09:00	10:00	01:00
7	6	Course 8	45	London	Teacher 2	28-Sep-21	Tuesday	0	0	09:00	10:00	01:00
8	7	Course 2	24	Birmingham	Teacher 2	20/10/2021	Wednesday	0	0	09:00	10:00	01:00
9	8	Course 2		Birmingham	Teacher 2	27/10/2021	Wednesday	0	0	09:00	10:00	01:00
10	9	Course 2	24	Birmingham	Teacher 2	12-Jan-21	Wednesday	0	0	09:00	10:00	01:00
11	10	Course 2	24	Birmingham	Teacher 2	12-Aug-21	Wednesday	0	0	09:00	10:00	01:00
12	11	Course 2	24	Birmingham	Teacher 8	15/12/2021	Wednesday	0	0	09:00	10:00	01:00
13	12	Course 3	24	Birmingham	Teacher 10	15/12/2021	Wednesday	0	0	09:00	10:00	01:00
14	13	Course 2	24	Birmingham	Teacher 2	01-Dec-22	Wednesday	0	0	09:00	10:00	01:00
15	14	Course 2	24	Birmingham	Teacher 2	02-Feb-22	Wednesday	0	0	09:00	10:00	01:00
16	14	Course 3	28	Manchester	Teacher 3		Tuesday	0	0	09:00	10:00	01:00
17	15	Course 3	28	Manchester	Teacher 3	22/2/2022	Tuesday	0	0	09:00	10:00	01:00
18	16	Course 4	23	London	Teacher 4	TBC	Tuesday	0	0	09:00	10:00	01:00
19	17	Course 5	98	Manchester	Teacher 1	28/9/2021	Tuesday	0	0	09:00	10:00	01:00
Sheet3

Scheduling Issues highlighted above

Teacher 1 is scheduled to Teach in BOTH London & Manchester on Tuesday 28/9/21 between 09:00 and 10:00 - Row 2 and Row 19 should be highlighted in YELLOW as a clash

Teacher 2 is scheduled to teach BOTH Course 2 and Course 8 at the same time on 28/9/21 in different rooms in London - Row 6 & 7 should be highlighted in YELLOW as a clash

Teachers 8 & 10 are scheduled to teach a different course at exactly the same time in the SAME ROOM on 15/12/2021 - rows 12 and 13 should be highlighted as a clash

There is missing delivery date infromation in Row 16 - this row should be highlighted in Yellow

Row 18 CONTAINS TBC in delivery dates column so row should be highlighted in Yellow

Row 9 Doesn't have a room number so should be highlight in Yellow

 

[EXCEL MAX]

Few days ago I was working something similar, so here is quick response...

Sub HighLightClashRows()
 
    Dim vRng As Range
    Dim vR As Long
    Dim vC As Integer
    Dim vN1 As Long, vN2 As Long
    Dim vColored As Boolean
    Dim vS As String
    Dim vWS3 As Worksheet
   
    Application.ScreenUpdating = False
    Set vWS3 = Sheets("Sheet3")
    With vWS3
        Set vRng = .Range("A2", Cells(.UsedRange.Rows.Count, 12))
        vRng.Interior.Color = xlNone
    End With
    vR = vRng.Rows.Count
    vC = vRng.Columns.Count
    vA1 = vRng
    ReDim vA2(1 To vR, 1 To 2)
   
'first clash
    For vN1 = 1 To vR
        vS = vA1(vN1, 5) & vA1(vN1, 6) & vA1(vN1, 10) & vA1(vN1, 11)
        vA2(vN1, 1) = vS
        vA2(vN1, 2) = vS
        vS = ""
    Next vN1
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA2(vN1, 1) = vA2(vN2, 2) And Not vA2(vN1, 1) = "" Then
                vRng.Range(Cells(vN2, 1), Cells(vN2, vC)). _
                    Interior.Color = vbYellow
                vColored = True
            End If
        Next vN2
        If vColored = True Then _
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
            vColored = False
    Next vN1
'second clash
    For vN1 = 1 To vR
        vS = vA1(vN1, 4) & vA1(vN1, 5) & vA1(vN1, 6) & vA1(vN1, 10) & vA1(vN1, 11)
        vA2(vN1, 1) = vS
        vA2(vN1, 2) = vS
        vS = ""
    Next vN1
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA2(vN1, 1) = vA2(vN2, 2) And Not vA2(vN1, 1) = "" Then
                vRng.Range(Cells(vN2, 1), Cells(vN2, vC)). _
                    Interior.Color = vbYellow
                vColored = True
            End If
        Next vN2
        If vColored = True Then _
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
            vColored = False
    Next vN1
'third clash
    For vN1 = 1 To vR
        vS = vA1(vN1, 3) & vA1(vN1, 4) & vA1(vN1, 6) & vA1(vN1, 10) & vA1(vN1, 11)
        vA2(vN1, 1) = vS
        vA2(vN1, 2) = vS
        vS = ""
    Next vN1
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA2(vN1, 1) = vA2(vN2, 2) And Not vA2(vN1, 1) = "" Then
                vRng.Range(Cells(vN2, 1), Cells(vN2, vC)). _
                    Interior.Color = vbYellow
                vColored = True
            End If
        Next vN2
        If vColored = True Then _
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
            vColored = False
    Next vN1
'missing delivery date
    For vN1 = 1 To vR
        If Trim(vA1(vN1, 6)) = "" Then
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
        End If
    Next vN1
'contains "TBC"
    For vN1 = 1 To vR
        If Trim(vA1(vN1, 6)) = "TBC" Then
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
        End If
    Next vN1
'doesn't have a room number
    For vN1 = 1 To vR
        If Trim(vA1(vN1, 3)) = "" Then
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
        End If
    Next vN1

End Sub

 

[markster]

Hey mate - thanks for this. It works well. This may not be possible but it it possible to add a comment in column M that indicates the row number of the clash - for instance if it identifies a clash involving rows 100, 150 & 200 is it possible to add 100,150, 200 in column M for those rows so I know that they are the rows that I need to review together? No probs if not but just thought I'd ask. Thanks again. Mark

 

[EXCEL MAX]

I did a modification on the first clash.
Hope so you will be able to implement it on other clashes.

Sub HighLightClashRows()
 
    Dim vRng As Range
    Dim vR As Long
    Dim vC As Integer
    Dim vN1 As Long, vN2 As Long, vN3 As Long
    Dim vColored As Boolean
    Dim vS As String
    Dim vWS3 As Worksheet
    Dim vOut
    
    Application.ScreenUpdating = False
    Set vWS3 = Sheets("Sheet3")
    With vWS3
        Set vRng = .Range("A2", Cells(.UsedRange.Rows.Count, 12))
        vRng.Interior.Color = xlNone
    End With
    vR = vRng.Rows.Count
    vC = vRng.Columns.Count
    vA1 = vRng
    ReDim vA2(1 To vR, 1 To 2)
    ReDim vA3(vR)
    Columns(13).ClearContents
'first clash
    For vN1 = 1 To vR
        vS = vA1(vN1, 5) & vA1(vN1, 6) & vA1(vN1, 10) & vA1(vN1, 11)
        vA2(vN1, 1) = vS
        vA2(vN1, 2) = vS
        vS = ""
    Next vN1
'highlight rows
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA2(vN1, 1) = vA2(vN2, 2) And Not vA2(vN1, 1) = "" Then
                vS = vS & "," & CStr(vN2)
                vA3(vN2) = vN2
                vColored = True
            End If
        Next vN2
        If vColored = True Then
            vS = Mid(vS & "," & CStr(vN1), 2)
            vA3(vN1) = vN1
            For vN3 = 1 To vR
                If Not vA3(vN3) = "" And _
                    Not vRng.Range(Cells(vN3, 1), Cells(vN3, vC)). _
                    Interior.Color = vbYellow Then
                    vRng.Range(Cells(vN3, 1), Cells(vN3, vC)). _
                    Interior.Color = vbYellow
                    vOut = Split(vS, ",")
                    vOut = Application.Substitute(vS, ",", "/", UBound(vOut))
                    vOut = Split(vOut, "/")
                    vRng.Cells(vA3(vN3), 13) = Join(Array(vOut(1), vOut(0)), ",")
                    vA3(vN3) = ""
                End If
                vColored = False
            Next vN3
            vS = ""
        End If
    Next vN1
    
End Sub

 

[markster]

Thanks very much mate - will add more. Have a good day. Mark