Блог

Я хотел бы добавить несколько критериев в этот код:

 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» и попытался добавить «И», «Или», «Если», «amp; _», но, похоже, ничего не работает для добавления второго критерия.
Какой-нибудь намек?

Изменение рабочего листа: цель содержит одну из нескольких строк

• Если вы планируете использовать исключительно contains для различных критериев, вы можете внести следующие изменения:

   Const CriteriaList As String = "high,critic" ' add more
  
  If LCase(cel.Value) Like "*" amp; LCase(Criteria(n)) amp; "*" 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