Ok, try the code below. Sample attached.
FYI - to make data appear for the demo, I changed majority of events to 2018.
Sub DisplayEvents()
Dim myArr, ResArr
Dim myWk As Date
Dim mySc
mySc = Sheets("MASTER CULTURAL CALENDAR").Range("A3").Value
With Sheets("Master Input")
myArr = .Range("A2:D" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For i = 1 To UBound(myArr)
myArr(i, 3) = myArr(i, 3) - (Weekday(myArr(i, 3), vbMonday) - 1)
Next
With Sheets("MASTER CULTURAL CALENDAR")
.UsedRange.Offset(3, 1).ClearContents
ResArr = .Range("A2:BB" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For j = 2 To UBound(ResArr, 2)
myWk = ResArr(1, j)
For i = 1 To UBound(ResArr)
For ii = 1 To UBound(myArr)
If myWk = myArr(ii, 3) And ResArr(i, 1) = myArr(ii, 1) Then
If mySc = "" Or mySc = 0 Then
ResArr(i, j) = IIf(Len(ResArr(i, j)) = 0, myArr(ii, 2), ResArr(i, j) & vbNewLine & myArr(ii, 2))
Else
If mySc = myArr(ii, 4) Then
ResArr(i, j) = IIf(Len(ResArr(i, j)) = 0, myArr(ii, 2), ResArr(i, j) & vbNewLine & myArr(ii, 2))
End If
End If
End If
Next
Next
Next
With Sheets("MASTER CULTURAL CALENDAR")
.Range("A2").Resize(UBound(ResArr), UBound(ResArr, 2)) = ResArr
With .Range("B2:BB" & .Cells(Rows.Count, "A").End(xlUp).Row)
.ColumnWidth = 32.71
.Columns.AutoFit
.Rows.AutoFit
End With
End With
End Sub
If you leave A3 blank or enter 0 there, it will show all events. Otherwise, if you enter 1 ~ 5, it will filter for that scale.
Bookmarks