VBA Code to highlight scheduling errors

M

markster

Well-known Member
Joined
May 23, 2002
Messages
579
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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
ABCDEFGHIJKL
1ReferenceCourse NameRoom NumberLocationAllocated TeacherDelivery DatesScheduled DaysPlanned SizeSizeScheduled Start TimeScheduled End TimeDuration
21Course 123LondonTeacher 128/9/2021Tuesday0009:0010:0001:00
32Course 123LondonTeacher 126/10/2021Tuesday0009:0010:0001:00
43Course 123LondonTeacher 116/11/2021Tuesday0009:0010:0001:00
54Course 123LondonTeacher 123/11/2021Tuesday0009:0010:0001:00
65Course 224LondonTeacher 228-Sep-21Tuesday0009:0010:0001:00
76Course 845LondonTeacher 228-Sep-21Tuesday0009:0010:0001:00
87Course 224BirminghamTeacher 220/10/2021Wednesday0009:0010:0001:00
98Course 2BirminghamTeacher 227/10/2021Wednesday0009:0010:0001:00
109Course 224BirminghamTeacher 212-Jan-21Wednesday0009:0010:0001:00
1110Course 224BirminghamTeacher 212-Aug-21Wednesday0009:0010:0001:00
1211Course 224BirminghamTeacher 815/12/2021Wednesday0009:0010:0001:00
1312Course 324BirminghamTeacher 1015/12/2021Wednesday0009:0010:0001:00
1413Course 224BirminghamTeacher 201-Dec-22Wednesday0009:0010:0001:00
1514Course 224BirminghamTeacher 202-Feb-22Wednesday0009:0010:0001:00
1614Course 328ManchesterTeacher 3Tuesday0009:0010:0001:00
1715Course 328ManchesterTeacher 322/2/2022Tuesday0009:0010:0001:00
1816Course 423LondonTeacher 4TBCTuesday0009:0010:0001:00
1917Course 598ManchesterTeacher 128/9/2021Tuesday0009:0010:0001: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 Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Few days ago I was working something similar, so here is quick response...
VBA Code: 
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
 
Upvote 0
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
 
Upvote 0
I did a modification on the first clash.
Hope so you will be able to implement it on other clashes.
VBA Code: 
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
 
Upvote 0
Solution
Thanks very much mate - will add more. Have a good day. Mark
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Custom VBA Row/Column Lookup Function
Replies
4
Views
270
pdbeiu
P
K
  • Question
VBA code for highlighting rows that match Yellow or Red
Replies
0
Views
297
Kassie1
K
S
  • Question
Copy only those rows that have green highlighted cells on random columns
Replies
0
Views
393
Sunnyji
S
S
  • Question
VBA for Userform to add data values
Replies
0
Views
439
Strycure12
S
M
  • Solved
VBA Code to split week ranges into separate lines.
2
Replies
10
Views
2K
Joe4
Joe4

Forum statistics

Threads
1,214,649
Messages
6,120,732
Members
448,987
Latest member
marion_davis

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top