vba - 添加多个条件：如果在单元格中输入单词 #1、#2 等，则消息框

问题描述

我想为此代码添加多个条件：

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

在当前状态下，这以这种方式工作：如果“A”列的单元格包含单词“high”，则弹出警报。 我想添加更多条件：如果“A”列中的单元格包含“高”，但如果“A”列中的单元格包含“评论家”，则显示相同的警告框。 我从“Const Criteria As String =”high”行开始，并尝试添加“And”、“Or”、“If”、“& _”，但似乎没有任何工作可以添加第二个条件. 有什么提示吗？

解决方法

工作表更改：目标包含多个字符串之一

• 如果您打算将 contains 专门用于各种条件，您可以进行以下更改：

  Const CriteriaList As String = "high,critic" ' add more
  
  If LCase(cel.Value) Like "*" & LCase(Criteria(n)) & "*" Then
  

代码

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