Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A2")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
On Error GoTo error_Handler
Application.EnableEvents = False
Call demo
error_Handler:
Application.EnableEvents = True
End Sub
Sheet code: right click on tab Sheet3>>View Code>>> Copy/paste above code
Option Explicit
Sub demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim a, b
Dim sdate, i As Long, r As Long, c As Long, nc As Long
Dim TimeRng As Range, ClassRng As Range
Set ws1 = Sheets("Sheet3")
Set ws2 = Sheets("Sheet4")
a = ws2.[A1].Offset(1).CurrentRegion
b = ws1.[A1].Offset(1).CurrentRegion
sdate = b(2, 1)
With ws1
Set TimeRng = .Range("A2:AW2")
Set ClassRng = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
.Range("B3:AW" & Cells(Rows.Count, "A").End(xlUp).Row).Clear
.Range("B3:AW" & Cells(Rows.Count, "A").End(xlUp).Row).Interior.Color = RGB(255, 220, 105)
For i = 3 To UBound(a, 1)
If a(i, 4) = sdate Then ' Class date matches selected Date
c = Application.Match(a(i, 5), TimeRng, 1) ' Find Start time column
r = Application.Match(a(i, 2), ClassRng, 0) ' Match CLASS row
nc = (a(i, 6) / 30) ' Number of 30 min periods
' .Cells(r, c).Resize(1, nc).Interior.Color = vbWhite ' Colour cells white
With .Cells(r, c).Resize(1, nc)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.Color = vbWhite ' Colour cells white'
End With
.Cells(r, c) = a(i, 3)
End If
Next i
End With
End Sub
In genreal module (Module1)
Change sheet names as required
CHANGING date in A2 (Sheet3) will invoke update of the calendar.
Added CLASS to list in Sheet4
Bookmarks