Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("H8,K8,K10")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim LastRow As Long, dic As Object, srcWS As Worksheet, advis As Range, rDate As Range
Set srcWS = Sheets("VehicleRejected")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set dic = CreateObject("Scripting.Dictionary")
Select Case Target.Address
Case "$H$8", "$K$8"
CalendarFrm.Show
Case "$K$10"
For Each advis In srcWS.Range("H5:H" & LastRow)
If Not dic.Exists(advis.Value) Then
dic.Add advis.Value, Nothing
End If
Next advis
With Target.Validation
.Delete
.Add xlValidateList, , , Join(dic.Keys, ",")
End With
End Select
Application.ScreenUpdating = True
End Sub
Sub ShowData()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Application.ScreenUpdating = False
Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, advis As Range, RowCount As Long
Set srcWS = Sheets("VehicleRejected")
Set desWS = Sheets("Sheet1")
LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sh.Unprotect "Bhaji2020"
With srcWS
.Cells(5, 1).CurrentRegion.AutoFilter 9, Range("K10").Value
.Cells(5, 1).AutoFilter 9, Criteria1:=">=" & Range("K8"), Operator:=xlAnd, Criteria2:="<=" & Range("H8")
If Range("H8") >= Now() < -5 Then
MsgBox ("No data to copy. Please check the criteria.")
.Range("A5").AutoFilter
Else
.AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
End If
.Range("A5").AutoFilter
End With
Application.ScreenUpdating = True
End Sub