vba - add multiple criteria: if entering word #1, #2 and so on in a cell, then messagebox - excel

Question

I'd like to add multiple criteria to this code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const srcCol As String = "A"
Const Criteria As String = "*high*"
Dim rng As Range: Set rng = Intersect(Columns(srcCol), Target)
If rng Is Nothing Then
Exit Sub
End If
Application.EnableEvents = False
Dim aRng As Range
Dim cel As Range
Dim foundCriteria As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If LCase(cel.Value) Like LCase(Criteria) Then
MsgBox ("Please check 2020 assessment")
foundCriteria = True
Exit For
End If
Next cel
If foundCriteria Then
Exit For
End If
Next aRng
Application.EnableEvents = True
End Sub
At the current state, this works in this way: if a cell of column "A" contains word "high", alert pop up.
I would like to add more criteria: if cell in column "A" contains "high" but ALSO if a cell in column "A" contains "critic", show me the same alert box.
I started from row "Const Criteria As String = "high", and tried adding "And", "Or", "If", "& _", but nothing seems working to add the second criteria.
Any hint?

Answer 1

A Worksheet Change: Target Contains One of Multiple Strings
If you plan on using exclusively contains for the various criteria, you can do the following changes:
Const CriteriaList As String = "high,critic" ' add more
If LCase(cel.Value) Like "*" & LCase(Criteria(n)) & "*" Then
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const srcCol As String = "A"
Const Delimiter As String = "," ' change if you need "," in the criterias
Const CriteriaList As String = "*high*,*critic*" ' add more
Dim rng As Range: Set rng = Intersect(Columns(srcCol), Target)
If rng Is Nothing Then
Exit Sub
End If
Dim Criteria() As String: Criteria = Split(CriteriaList, Delimiter)
Application.EnableEvents = False
Dim aRng As Range
Dim cel As Range
Dim n As Long
Dim foundCriteria As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
For n = 0 To UBound(Criteria)
If LCase(cel.Value) Like LCase(Criteria(n)) Then
MsgBox ("Please check 2020 assessment")
foundCriteria = True
Exit For
End If
Next n
Next cel
If foundCriteria Then
Exit For
End If
Next aRng
Application.EnableEvents = True
End Sub